dy>

Theory Term_Context

section ‹Preliminaries›

theory Term_Context
  imports First_Order_Terms.Term
    Knuth_Bendix_Order.Subterm_and_Context
    Polynomial_Factorization.Missing_List
begin

subsection ‹Additional functionality on @{type term} and @{type ctxt}›
subsubsection ‹Positions›

type_synonym pos = "nat list"
context
  notes conj_cong [fundef_cong]
begin

fun poss :: "('f, 'v) term ⇒ pos set" where
  "poss (Var x) = {[]}"
| "poss (Fun f ss) = {[]} ∪ {i # p | i p. i < length ss ∧ p ∈ poss (ss ! i)}"
end

fun hole_pos where
  "hole_pos □ = []"
| "hole_pos (More f ss D ts) = length ss # hole_pos D"

definition position_less_eq (infixl "≤p" 67) where
  "p ≤p q ⟷ (∃ r. p @ r = q)"

abbreviation position_less (infixl "<p" 67) where
  "p <p q ≡ p ≠ q ∧ p ≤p q"

definition position_par  (infixl "⊥" 67) where
  "p ⊥ q ⟷ ¬ (p ≤p q) ∧ ¬ (q ≤p p)"

fun remove_prefix where
  "remove_prefix (x # xs) (y # ys) = (if x = y then remove_prefix xs ys else None)"
| "remove_prefix [] ys = Some ys"
| "remove_prefix xs [] = None"

definition pos_diff  (infixl "-p" 67) where
  "p -p q = the (remove_prefix q p)"

fun subt_at :: "('f, 'v) term ⇒ pos ⇒ ('f, 'v) term" (infixl "|'_" 67) where
  "s |_ [] = s"
| "Fun f ss |_ (i # p) = (ss ! i) |_ p"
| "Var x |_ _ = undefined"

fun ctxt_at_pos where
  "ctxt_at_pos s [] = □"
| "ctxt_at_pos (Fun f ss) (i # p) = More f (take i ss) (ctxt_at_pos (ss ! i) p) (drop (Suc i) ss)"
| "ctxt_at_pos (Var x) _ = undefined"

fun replace_term_at ("_[_ ← _]" [1000, 0, 0] 1000) where
  "replace_term_at s [] t = t"
| "replace_term_at (Var x) ps t = (Var x)"
| "replace_term_at (Fun f ts) (i # ps) t =
    (if i < length ts then Fun f (ts[i:=(replace_term_at (ts ! i) ps t)]) else Fun f ts)"

fun fun_at :: "('f, 'v) term ⇒ pos ⇒ ('f + 'v) option" where
  "fun_at (Var x) [] = Some (Inr x)"
| "fun_at (Fun f ts) [] = Some (Inl f)"
| "fun_at (Fun f ts) (i # p) = (if i < length ts then fun_at (ts ! i) p else None)"
| "fun_at _ _ = None"

subsubsection ‹Computing the signature›

fun funas_term where
  "funas_term (Var x) = {}"
| "funas_term (Fun f ts) = insert (f, length ts) (⋃ (set (map funas_term ts)))"

fun funas_ctxt where
  "funas_ctxt □ = {}"
| "funas_ctxt (More f ss C ts) = (⋃ (set (map funas_term ss))) ∪
    insert (f, Suc (length ss + length ts)) (funas_ctxt C) ∪ (⋃ (set (map funas_term ts)))"

subsubsection ‹Groundness›

fun ground where
  "ground (Var x) = False"
| "ground (Fun f ts) = (∀ t ∈ set ts. ground t)"

fun ground_ctxt where
  "ground_ctxt □ ⟷ True"
| "ground_ctxt (More f ss C ts) ⟷ (∀ t ∈ set ss. ground t) ∧ ground_ctxt C ∧ (∀ t ∈ set ts. ground t)"

subsubsection ‹Depth›
fun depth where
  "depth (Var x) = 0"
| "depth (Fun f []) = 0"
| "depth (Fun f ts) = Suc (Max (depth ` set ts))"

subsubsection ‹Type conversion›

text ‹We require a function which adapts the type of variables of a term,
   so that states of the automaton and variables in the term language can be
   chosen independently.›

abbreviation "map_vars_term f ≡ map_term (λ x. x) f"
abbreviation "map_funs_term f ≡ map_term f (λ x. x)"
abbreviation "map_both f ≡ map_prod f f"

definition adapt_vars :: "('f, 'q) term ⇒ ('f,'v)term" where 
  [code del]: "adapt_vars ≡ map_vars_term (λ_. undefined)"

abbreviation "map_vars_ctxt f ≡ map_ctxt (λx. x) f"
definition adapt_vars_ctxt :: "('f,'q)ctxt ⇒ ('f,'v)ctxt" where
  [code del]: "adapt_vars_ctxt = map_vars_ctxt (λ_. undefined)"


subsection ‹Properties of @{type pos}›

lemma position_less_eq_induct [consumes 1]:
  assumes "p ≤p q" and "⋀ p. P p p"
    and "⋀ p q r. p ≤p q ⟹ P p q ⟹ P p (q @ r)"
  shows "P p q" using assms
proof (induct p arbitrary: q)
  case Nil then show ?case
    by (metis append_Nil position_less_eq_def)
next
  case (Cons a p)
  then show ?case
    by (metis append_Nil2 position_less_eq_def)
qed

text ‹We show the correspondence between the function @{const remove_prefix} and
the order on positions @{const position_less_eq}. Moreover how it can be used to
compute the difference of positions.›

lemma remove_prefix_Nil [simp]:
  "remove_prefix xs xs = Some []"
  by (induct xs) auto

lemma remove_prefix_Some:
  assumes "remove_prefix xs ys = Some zs"
  shows "ys = xs @ zs" using assms
proof (induct xs arbitrary: ys)
  case (Cons x xs)
  show ?case using Cons(1)[of "tl ys"] Cons(2)
    by (cases ys) (auto split: if_splits)
qed auto

lemma remove_prefix_append:
  "remove_prefix xs (xs @ ys) = Some ys"
  by (induct xs) auto

lemma remove_prefix_iff:
  "remove_prefix xs ys = Some zs ⟷ ys = xs @ zs"
  using remove_prefix_Some remove_prefix_append
  by blast

lemma position_less_eq_remove_prefix:
  "p ≤p q ⟹ remove_prefix p q ≠ None"
  by (induct rule: position_less_eq_induct) (auto simp: remove_prefix_iff)

text ‹Simplification rules on @{const position_less_eq}, @{const pos_diff},
  and @{const position_par}.›

lemma position_less_refl [simp]: "p ≤p p"
  by (auto simp: position_less_eq_def)

lemma position_less_eq_Cons [simp]:
  "(i # ps) ≤p (j # qs) ⟷ i = j ∧ ps ≤p qs"
  by (auto simp: position_less_eq_def)

lemma position_less_Nil_is_bot [simp]: "[] ≤p p"
  by (auto simp: position_less_eq_def)

lemma position_less_Nil_is_bot2 [simp]: "p ≤p [] ⟷ p = []"
  by (auto simp: position_less_eq_def)

lemma position_diff_Nil [simp]: "q -p [] = q"
  by (auto simp: pos_diff_def)

lemma position_diff_Cons [simp]:
  "(i # ps) -p (i # qs) = ps -p qs"
  by (auto simp: pos_diff_def)

lemma Nil_not_par [simp]:
  "[] ⊥ p ⟷ False"
  "p ⊥ [] ⟷ False"
  by (auto simp: position_par_def)

lemma par_not_refl [simp]: "p ⊥ p ⟷ False"
  by (auto simp: position_par_def)

lemma par_Cons_iff:
  "(i # ps) ⊥ (j # qs) ⟷ (i ≠ j ∨ ps ⊥ qs)"
  by (auto simp: position_par_def)


text ‹Simplification rules on @{const poss}.›

lemma Nil_in_poss [simp]: "[] ∈ poss t"
  by (cases t) auto

lemma poss_Cons [simp]:
  "i # p ∈ poss t ⟹ [i] ∈ poss t"
  by (cases t) auto

lemma poss_Cons_poss:
  "i # q ∈ poss t ⟷ i < length (args t) ∧ q ∈ poss (args t ! i)"
  by (cases t) auto

lemma poss_append_poss:
  "p @ q ∈ poss t ⟷ p ∈ poss t ∧ q ∈ poss (t |_ p)"
proof (induct p arbitrary: t)
  case (Cons i p)
  from Cons[of "args t ! i"] show ?case
    by (cases t) auto
qed auto


text ‹Simplification rules on @{const hole_pos}›

lemma hole_pos_map_vars [simp]:
  "hole_pos (map_vars_ctxt f C) = hole_pos C"
  by (induct C) auto

lemma hole_pos_in_ctxt_apply [simp]: "hole_pos C ∈ poss C⟨u⟩"
  by (induct C) auto

subsection ‹Properties of @{const ground} and @{const ground_ctxt}›

lemma ground_vars_term_empty [simp]:
  "ground t ⟹ vars_term t = {}"
  by (induct t) auto

lemma ground_map_term [simp]:
  "ground (map_term f h t) = ground t"
  by (induct t) auto

lemma ground_ctxt_apply [simp]:
  "ground C⟨t⟩ ⟷ ground_ctxt C ∧ ground t"
  by (induct C) auto

lemma ground_ctxt_comp [intro]:
  "ground_ctxt C ⟹ ground_ctxt D ⟹ ground_ctxt (C ∘c D)"
  by (induct C) auto

lemma ctxt_comp_n_pres_ground [intro]:
  "ground_ctxt C ⟹ ground_ctxt (C^n)"
  by (induct n arbitrary: C) auto

lemma subterm_eq_pres_ground:
  assumes "ground s" and "s ⊵ t"
  shows "ground t" using assms(2,1)
  by (induct) auto

lemma ground_substD:
  "ground (l ⋅ σ) ⟹ x ∈ vars_term l ⟹ ground (σ x)"
  by (induct l) auto

lemma ground_substI:
  "(⋀ x. x ∈ vars_term s ⟹ ground (σ x)) ⟹ ground (s ⋅ σ)"
  by (induct s) auto


subsection ‹Properties on signature induced by a term @{type term}/context @{type ctxt}›

lemma funas_ctxt_apply [simp]:
  "funas_term C⟨t⟩ = funas_ctxt C ∪ funas_term t"
  by (induct C) auto

lemma funas_term_map [simp]:
  "funas_term (map_term f h t) = (λ (g, n). (f g, n)) ` funas_term t"
  by (induct t) auto

lemma funas_term_subst:
  "funas_term (l ⋅ σ) = funas_term l ∪ (⋃ (funas_term ` σ ` vars_term l))"
  by (induct l) auto

lemma funas_ctxt_comp [simp]:
  "funas_ctxt (C ∘c D) = funas_ctxt C ∪ funas_ctxt D"
  by (induct C) auto

lemma ctxt_comp_n_funas [simp]:
  "(f, v) ∈ funas_ctxt (C^n) ⟹ (f, v) ∈ funas_ctxt C"
  by (induct n arbitrary: C) auto

lemma ctxt_comp_n_pres_funas [intro]:
  "funas_ctxt C ⊆ ℱ ⟹ funas_ctxt (C^n) ⊆ ℱ"
  by (induct n arbitrary: C) auto

subsection ‹Properties on subterm at given position @{const subt_at}›

lemma subt_at_Cons_comp:
  "i # p ∈ poss s ⟹ (s |_ [i]) |_ p = s |_ (i # p)"
  by (cases s) auto

lemma ctxt_at_pos_subt_at_pos:
  "p ∈ poss t ⟹ (ctxt_at_pos t p)⟨u⟩ |_ p = u"
proof (induct p arbitrary: t)
  case (Cons i p)
  then show ?case using id_take_nth_drop
    by (cases t) (auto simp: nth_append)
qed auto

lemma ctxt_at_pos_subt_at_id:
  "p ∈ poss t ⟹ (ctxt_at_pos t p)⟨t |_ p⟩ = t"
proof (induct p arbitrary: t)
  case (Cons i p)
  then show ?case using id_take_nth_drop
    by (cases t) force+ 
qed auto

lemma subst_at_ctxt_at_eq_termD:
  assumes "s = t" "p ∈ poss t"
  shows "s |_ p = t |_ p ∧ ctxt_at_pos s p = ctxt_at_pos t p" using assms
  by auto

lemma subst_at_ctxt_at_eq_termI:
  assumes "p ∈ poss s" "p ∈ poss t"
    and "s |_p = t |_ p"
    and "ctxt_at_pos s p = ctxt_at_pos t p"
  shows "s = t" using assms
  by (metis ctxt_at_pos_subt_at_id)

lemma subt_at_subterm_eq [intro!]:
  "p ∈ poss t ⟹ t ⊵ t |_ p"
proof (induct p arbitrary: t)
  case (Cons i p)
  from Cons(1)[of "args t ! i"] Cons(2) show ?case
    by (cases t) force+
qed auto

lemma subt_at_subterm [intro!]:
  "p ∈ poss t ⟹ p ≠ [] ⟹  t ⊳ t |_ p"
proof (induct p arbitrary: t)
  case (Cons i p)
  from Cons(1)[of "args t ! i"] Cons(2) show ?case
    by (cases t) force+
qed auto


lemma ctxt_at_pos_hole_pos [simp]: "ctxt_at_pos C⟨s⟩ (hole_pos C) = C"
  by (induct C) auto

subsection ‹Properties on replace terms at a given position
  @{const replace_term_at}›

lemma replace_term_at_not_poss [simp]:
  "p ∉ poss s ⟹ s[p ← t] = s"
proof (induct s arbitrary: p)
  case (Var x) then show ?case by (cases p) auto
next
  case (Fun f ts) show ?case using Fun(1)[OF nth_mem] Fun(2)
    by (cases p) (auto simp: min_def intro!: nth_equalityI)
qed

lemma replace_term_at_replace_at_conv:
  "p ∈ poss s ⟹ (ctxt_at_pos s p)⟨t⟩ = s[p ← t]"
  by (induct s arbitrary: p) (auto simp: upd_conv_take_nth_drop)

lemma parallel_replace_term_commute [ac_simps]:
  "p ⊥ q ⟹ s[p ← t][q ← u] = s[q ← u][p ← t]"
proof (induct s arbitrary: p q)
  case (Var x) then show ?case
    by (cases p; cases q) auto
next
  case (Fun f ts)
  from Fun(2) have "p ≠ []" "q ≠ []" by auto
  then obtain i j ps qs where [simp]: "p = i # ps" "q = j # qs"
    by (cases p; cases q) auto
  have "i ≠ j ⟹ (Fun f ts)[p ← t][q ← u] = (Fun f ts)[q ← u][p ← t]"
    by (auto simp: list_update_swap)
  then show ?case using Fun(1)[OF nth_mem, of j ps qs] Fun(2)
    by (cases "i = j") (auto simp: par_Cons_iff)
qed

lemma replace_term_at_above [simp]:
  "p ≤p q ⟹ s[q ← t][p ← u] = s[p ← u]"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "tl q" "args s ! i"] Cons(2)
    by (cases q; cases s) auto
qed auto

lemma replace_term_at_below [simp]:
  "p <p q ⟹ s[p ← t][q ← u] = s[p ← t[q -p p ← u]]"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "tl q" "args s ! i"] Cons(2)
    by (cases q; cases s) auto
qed auto

lemma replace_at_hole_pos [simp]: "C⟨s⟩[hole_pos C ← t] = C⟨t⟩"
  by (induct C) auto

subsection ‹Properties on @{const adapt_vars} and @{const adapt_vars_ctxt}›

lemma adapt_vars2:
  "adapt_vars (adapt_vars t) = adapt_vars t"
  by (induct t) (auto simp add: adapt_vars_def)

lemma adapt_vars_simps[code, simp]: "adapt_vars (Fun f ts) = Fun f (map adapt_vars ts)"
  by (induct ts, auto simp: adapt_vars_def)

lemma adapt_vars_reverse: "ground t ⟹ adapt_vars t' = t ⟹ adapt_vars t = t'"
  unfolding adapt_vars_def 
proof (induct t arbitrary: t')
  case (Fun f ts)
  then show ?case by (cases t') (auto simp add: map_idI)
qed auto

lemma ground_adapt_vars [simp]: "ground (adapt_vars t) = ground t"
  by (simp add: adapt_vars_def)
lemma funas_term_adapt_vars[simp]: "funas_term (adapt_vars t) = funas_term t" by (simp add: adapt_vars_def)

lemma adapt_vars_adapt_vars[simp]: fixes t :: "('f,'v)term"
  assumes g: "ground t"
  shows "adapt_vars (adapt_vars t :: ('f,'w)term) = t"
proof -
  let ?t' = "adapt_vars t :: ('f,'w)term"
  have gt': "ground ?t'" using g by auto
  from adapt_vars_reverse[OF gt', of t] show ?thesis by blast
qed

lemma adapt_vars_inj:
  assumes "adapt_vars x = adapt_vars y" "ground x" "ground y"
  shows "x = y"
  using adapt_vars_adapt_vars assms by metis

lemma adapt_vars_ctxt_simps[simp, code]: 
  "adapt_vars_ctxt (More f bef C aft) = More f (map adapt_vars bef) (adapt_vars_ctxt C) (map adapt_vars aft)"
  "adapt_vars_ctxt Hole = Hole" unfolding adapt_vars_ctxt_def adapt_vars_def by auto

lemma adapt_vars_ctxt[simp]: "adapt_vars (C ⟨ t ⟩ ) = (adapt_vars_ctxt C) ⟨ adapt_vars t ⟩"
  by (induct C, auto)

lemma adapt_vars_subst[simp]: "adapt_vars (l ⋅ σ) = l ⋅ (λ x. adapt_vars (σ x))"
  unfolding adapt_vars_def
  by (induct l) auto

lemma adapt_vars_gr_map_vars [simp]:
  "ground t ⟹ map_vars_term f t = adapt_vars t"
  by (induct t) auto


lemma adapt_vars_gr_ctxt_of_map_vars [simp]:
  "ground_ctxt C ⟹ map_vars_ctxt f C = adapt_vars_ctxt C"
  by (induct C) auto

subsubsection ‹Equality on ground terms/contexts by positions and symbols›

lemma fun_at_def':
  "fun_at t p = (if p ∈ poss t then
    (case t |_ p of Var x ⇒ Some (Inr x) | Fun f ts ⇒ Some (Inl f)) else None)"
  by (induct t p rule: fun_at.induct) auto

lemma fun_at_None_nposs_iff:
  "fun_at t p = None ⟷ p ∉ poss t"
  by (auto simp: fun_at_def') (meson term.case_eq_if)

lemma eq_term_by_poss_fun_at:
  assumes "poss s = poss t" "⋀p. p ∈ poss s ⟹ fun_at s p = fun_at t p"
  shows "s = t"
  using assms
proof (induct s arbitrary: t)
  case (Var x) then show ?case
    by (cases t) simp_all
next
  case (Fun f ss) note Fun' = this
  show ?case
  proof (cases t)
    case (Var x) show ?thesis using Fun'(3)[of "[]"] by (simp add: Var)
  next
    case (Fun g ts)
    have *: "length ss = length ts"
      using Fun'(3) arg_cong[OF Fun'(2), of "λP. card {i |i p. i # p ∈ P}"]
      by (auto simp: Fun exI[of "λx. x ∈ poss _", OF Nil_in_poss])
    then have "i < length ss ⟹ poss (ss ! i) = poss (ts ! i)" for i
      using arg_cong[OF Fun'(2), of "λP. {p. i # p ∈ P}"] by (auto simp: Fun)
    then show ?thesis using * Fun'(2) Fun'(3)[of "[]"] Fun'(3)[of "_ # _ :: pos"]
      by (auto simp: Fun intro!: nth_equalityI Fun'(1)[OF nth_mem, of n "ts ! n" for n])
  qed
qed

lemma eq_ctxt_at_pos_by_poss:
  assumes "p ∈ poss s" "p ∈ poss t"
    and "⋀ q. ¬ (p ≤p q) ⟹ q ∈ poss s ⟷ q ∈ poss t"
    and "(⋀ q. q ∈ poss s ⟹ ¬ (p ≤p q) ⟹ fun_at s q = fun_at t q)"
  shows "ctxt_at_pos s p = ctxt_at_pos t p" using assms
proof (induct p arbitrary: s t)
  case (Cons i p)
  from Cons(2, 3) Cons(4, 5)[of "[]"] obtain f ss ts where [simp]: "s = Fun f ss" "t = Fun f ts"
    by (cases s; cases t) auto
  have flt: "j < i ⟹ j # q ∈ poss s ⟹ fun_at s (j # q) = fun_at t (j # q)" for j q
    by (intro Cons(5)) auto
  have fgt: "i < j ⟹ j # q ∈ poss s ⟹ fun_at s (j # q) = fun_at t (j # q)" for j q
    by (intro Cons(5)) auto
  have lt: "j < i ⟹ j # q ∈ poss s ⟷ j # q ∈ poss t" for j q by (intro Cons(4)) auto
  have gt: "i < j ⟹ j # q ∈ poss s ⟷ j # q ∈ poss t" for j q by (intro Cons(4)) auto
  from this[of _ "[]"] have "i < j ⟹ j < length ss ⟷ j < length ts" for j by auto
  from this Cons(2, 3) have l: "length ss = length ts" by auto (meson nat_neq_iff)
  have "ctxt_at_pos (ss ! i) p = ctxt_at_pos (ts ! i) p" using Cons(2, 3) Cons(4-)[of "i # q" for q] 
    by (intro Cons(1)[of "ss ! i" "ts ! i"]) auto
  moreover have "take i ss = take i ts" using l lt Cons(2, 3) flt
    by (intro nth_equalityI) (auto intro!: eq_term_by_poss_fun_at)
  moreover have "drop (Suc i) ss = drop (Suc i) ts" using l Cons(2, 3) fgt gt[of "Suc i + j" for j]
    by (intro nth_equalityI) (auto simp: nth_map intro!: eq_term_by_poss_fun_at, fastforce+)
  ultimately show ?case by auto
qed auto


subsection ‹Misc›

lemma fun_at_hole_pos_ctxt_apply [simp]:
  "fun_at C⟨t⟩ (hole_pos C) = fun_at t []"
  by (induct C) auto

lemma vars_term_ctxt_apply [simp]:
  "vars_term C⟨t⟩ = vars_ctxt C ∪ vars_term t"
  by (induct C arbitrary: t) auto

lemma map_vars_term_ctxt_apply:
  "map_vars_term f C⟨t⟩ = (map_vars_ctxt f C)⟨map_vars_term f t⟩"
  by (induct C) auto

lemma map_term_replace_at_dist:
  "p ∈ poss s ⟹ (map_term f g s)[p ← (map_term f g t)] = map_term f g (s[p ← t])"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) (auto simp: nth_list_update intro!: nth_equalityI)
qed auto

end
y>

Theory Basic_Utils

theory Basic_Utils
  imports Term_Context
begin

primrec is_Inl where
  "is_Inl (Inl q) ⟷ True"
| "is_Inl (Inr q) ⟷ False"

primrec is_Inr where
  "is_Inr (Inr q) ⟷ True"
| "is_Inr (Inl q) ⟷ False"

fun remove_sum where
  "remove_sum (Inl q) = q"
| "remove_sum (Inr q) = q"


text ‹List operations›

definition filter_rev_nth where
  "filter_rev_nth P xs i = length (filter P (take (Suc i) xs)) - 1"

lemma filter_rev_nth_butlast:
  "¬ P (last xs) ⟹ filter_rev_nth P xs i = filter_rev_nth P (butlast xs) i"
  unfolding filter_rev_nth_def
  by (induct xs arbitrary: i rule: rev_induct) (auto simp add: take_Cons')

lemma filter_rev_nth_idx:
  assumes "i < length xs" "P (xs ! i)" "ys = filter P xs"
  shows "xs ! i = ys ! (filter_rev_nth P xs i) ∧ filter_rev_nth P xs i < length ys"
  using assms unfolding filter_rev_nth_def
proof (induct xs arbitrary: ys i)
  case (Cons x xs) show ?case
  proof (cases "P x")
    case True
    then obtain ys' where *:"ys = x # ys'" using Cons(4) by auto
    show ?thesis using True Cons(1)[of "i - 1" ys'] Cons(2-)
      unfolding *
      by (cases i) (auto simp: nth_Cons' take_Suc_conv_app_nth)
  next
    case False
    then show ?thesis using Cons(1)[of "i - 1" ys] Cons(2-)
      by (auto simp: nth_Cons')
  qed
qed auto


(*replace list_of_permutation_n with n_lists *)

primrec add_elem_list_lists :: "'a ⇒ 'a list ⇒ 'a list list" where
  "add_elem_list_lists x [] = [[x]]"
| "add_elem_list_lists x (y # ys) = (x # y # ys) # (map ((#) y) (add_elem_list_lists x ys))"

lemma length_add_elem_list_lists:
  "ys ∈ set (add_elem_list_lists x xs) ⟹ length ys = Suc (length xs)"
  by (induct xs arbitrary: ys) auto

lemma add_elem_list_listsE:
  assumes "ys ∈ set (add_elem_list_lists x xs)"
  shows "∃ n ≤ length xs. ys = take n xs @ x # drop n xs" using assms
proof(induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by auto fastforce
qed auto

lemma add_elem_list_listsI:
  assumes "n ≤ length xs" "ys = take n xs @ x # drop n xs"
  shows "ys ∈ set (add_elem_list_lists x xs)" using assms
proof  (induct xs arbitrary: ys n)
  case (Cons a xs)
  then show ?case
    by (cases n) (auto simp: image_iff) 
qed auto

lemma add_elem_list_lists_def':
  "set (add_elem_list_lists x xs) = {ys | ys n. n ≤ length xs ∧ ys = take n xs @ x # drop n xs}"
  using add_elem_list_listsI add_elem_list_listsE
  by fastforce

fun list_of_permutation_element_n :: "'a ⇒ nat ⇒ 'a list ⇒ 'a list list" where
  "list_of_permutation_element_n x 0 L = [[]]"
|  "list_of_permutation_element_n x (Suc n) L = concat (map (add_elem_list_lists x) (List.n_lists n L))"

lemma list_of_permutation_element_n_conv:
  assumes "n ≠ 0"
  shows "set (list_of_permutation_element_n x n L) =
    {xs | xs i. i < length xs ∧ (∀ j < length xs. j ≠ i ⟶ xs ! j ∈ set L) ∧ length xs = n ∧ xs ! i = x}" (is "?Ls = ?Rs")
proof (intro equalityI)
  from assms obtain j where [simp]: "n = Suc j" using assms by (cases n) auto
  {fix ys assume "ys ∈ ?Ls"
    then obtain xs i where wit: "xs ∈ set (List.n_lists j L)" "i ≤ length xs"
      "ys = take i xs @ x # drop i xs"
      by (auto dest: add_elem_list_listsE)
    then have "i < length ys" "length ys = Suc (length xs)" "ys ! i = x"
      by (auto simp: nth_append)
    moreover have "∀ j < length ys. j ≠ i ⟶ ys ! j ∈ set L" using wit(1, 2)
      by (auto simp: wit(3) min_def nth_append set_n_lists)
    ultimately have "ys ∈ ?Rs" using wit(1) unfolding set_n_lists
      by auto}
  then show "?Ls ⊆ ?Rs" by blast
next
  {fix xs assume "xs ∈ ?Rs"
    then obtain i where wit: "i < length xs" "∀ j < length xs. j ≠ i ⟶ xs ! j ∈ set L"
      "length xs = n" "xs ! i = x"
      by blast
    then have *: "xs ∈ set (add_elem_list_lists (xs ! i) (take i xs @ drop (Suc i) xs))"
      unfolding add_elem_list_lists_def'
      by (auto simp: min_def intro!: nth_equalityI)
         (metis Cons_nth_drop_Suc Suc_pred append_Nil append_take_drop_id assms diff_le_self diff_self_eq_0 drop_take less_Suc_eq_le nat_less_le take0)
    have [simp]: "x ∈ set (take i xs) ⟹ x ∈ set L" 
      "x ∈ set (drop (Suc i) xs) ⟹ x ∈ set L" for x using wit(2)
      by (auto simp: set_conv_nth)
    have "xs ∈ ?Ls" using wit
      by (cases "length xs")
         (auto simp: set_n_lists nth_append * min_def
               intro!: exI[of _ "take i xs @ drop (Suc i) xs"])}
  then show "?Rs ⊆ ?Ls" by blast
qed

lemma list_of_permutation_element_n_iff:
  "set (list_of_permutation_element_n x n L) =
    (if n = 0 then {[]} else {xs | xs i. i < length xs ∧ (∀ j < length xs. j ≠ i ⟶ xs ! j ∈ set L) ∧ length xs = n ∧ xs ! i = x})"
proof (cases n)
  case (Suc nat)
  then have [simp]: "Suc nat ≠ 0" by auto
  then show ?thesis
    by (auto simp: list_of_permutation_element_n_conv)
qed auto

lemma list_of_permutation_element_n_conv':
  assumes "x ∈ set L" "0 < n"
  shows "set (list_of_permutation_element_n x n L) =
      {xs. set xs ⊆ insert x (set L) ∧ length xs = n ∧ x ∈ set xs}"
proof -
  from assms(2) have *: "n ≠ 0" by simp
  show ?thesis using assms
    unfolding list_of_permutation_element_n_conv[OF *]
    by (auto simp: in_set_conv_nth) 
       (metis in_set_conv_nth insert_absorb subsetD)+
qed

text ‹Misc›

lemma in_set_idx:
  "x ∈ set xs ⟹ ∃ i < length xs. xs ! i = x"
  by (induct xs) force+

lemma set_list_subset_eq_nth_conv:
  "set xs ⊆ A ⟷ (∀ i < length xs. xs ! i ∈ A)"
  by (metis in_set_conv_nth subset_code(1))

lemma map_eq_nth_conv:
  "map f xs = map g ys ⟷ length xs = length ys ∧ (∀ i < length ys. f (xs ! i) = g (ys ! i))"
  using map_eq_imp_length_eq[of f xs g ys]
  by (auto intro: nth_equalityI) (metis nth_map)

lemma nth_append_Cons: "(xs @ y # zs) ! i =
  (if i < length xs then xs ! i else if i = length xs then y else zs ! (i - Suc (length xs)))"
  by (cases i "length xs" rule: linorder_cases, auto simp: nth_append)

lemma map_prod_times:
  "f ` A × g ` B = map_prod f g ` (A × B)"
  by auto

lemma trancl_full_on: "(X × X)+ = X × X"
  using trancl_unfold_left[of "X × X"] trancl_unfold_right[of "X × X"] by auto

lemma trancl_map:
  assumes simu: "⋀x y. (x, y) ∈ r ⟹ (f x, f y) ∈ s"
    and steps: "(x, y) ∈ r+"
  shows "(f x, f y) ∈ s+" using steps
proof (induct)
  case (step y z) show ?case using step(3) simu[OF step(2)] 
    by auto
qed (auto simp: simu)

lemma trancl_map_prod_mono:
  "map_both f ` R+ ⊆ (map_both f ` R)+"
proof -
  have "(f x, f y) ∈ (map_both f ` R)+" if "(x, y) ∈ R+" for x y using that
    by (induct) (auto intro: trancl_into_trancl)
  then show ?thesis by auto
qed

lemma trancl_map_both_Restr:
  assumes "inj_on f X"
  shows "(map_both f ` Restr R X)+ = map_both f ` (Restr R X)+"
proof -
  have [simp]:
    "map_prod (inv_into X f ∘ f) (inv_into X f ∘ f) ` Restr R X = Restr R X"
    using inv_into_f_f[OF assms]
    by (intro equalityI subrelI)
       (force simp: comp_def map_prod_def image_def split: prod.splits)+
  have [simp]:
    "map_prod (f ∘ inv_into X f) (f ∘ inv_into X f) ` (map_both f ` Restr R X)+ = (map_both f ` Restr R X)+"
    using f_inv_into_f[of _ f X] subsetD[OF trancl_mono_set[OF image_mono[of "Restr R X" "X × X" "map_both f"]]]
    by (intro equalityI subrelI) (auto simp: map_prod_surj_on trancl_full_on comp_def rev_image_eqI)
  show ?thesis using assms trancl_map_prod_mono[of f "Restr R X"]
      image_mono[OF trancl_map_prod_mono[of "inv_into X f" "map_both f ` Restr R X"], of "map_both f"]
    by (intro equalityI) (simp_all add: image_comp map_prod.comp)
qed

lemma inj_on_trancl_map_both:
  assumes "inj_on f (fst ` R ∪ snd ` R)"
  shows "(map_both f ` R)+ = map_both f ` R+"
proof -
  have [simp]: "Restr R (fst ` R ∪ snd ` R) = R"
    by (force simp: image_def)
  then show ?thesis using assms
    using trancl_map_both_Restr[of f "fst ` R ∪ snd ` R" R]
    by simp
qed


lemma kleene_induct:
  "A ⊆ X ⟹ B O X ⊆ X ⟹ X O C ⊆ X ⟹ B* O A O C* ⊆ X"
  using relcomp_mono[OF compat_tr_compat[of B X] subset_refl, of "C*"] compat_tr_compat[of "C¯" "X¯"]
    relcomp_mono[OF relcomp_mono, OF subset_refl _ subset_refl, of A X "B*" "C*"]
  unfolding rtrancl_converse converse_relcomp[symmetric] converse_mono by blast

lemma kleene_trancl_induct:
  "A ⊆ X ⟹ B O X ⊆ X ⟹ X O C ⊆ X ⟹ B+ O A O C+ ⊆ X"
  using kleene_induct[of A X B C]
  by (auto simp: rtrancl_eq_or_trancl)
     (meson relcomp.relcompI subsetD trancl_into_rtrancl)

lemma rtrancl_Un2_separatorE:
  "B O A = {} ⟹ (A ∪ B)* = A* ∪ A* O B*"
  by (metis R_O_Id empty_subsetI relcomp_distrib rtrancl_U_push rtrancl_reflcl_absorb sup_commute)

lemma trancl_Un2_separatorE:
  assumes "B O A = {}"
  shows "(A ∪ B)+ = A+ ∪ A+ O B+ ∪ B+" (is "?Ls = ?Rs")
proof -
  {fix x y assume "(x, y) ∈ ?Ls"
    then have "(x, y) ∈ ?Rs" using assms
    proof (induct)
      case (step y z)
      then show ?case
        by (auto simp add: trancl_into_trancl relcomp_unfold dest: tranclD2)
    qed auto}
  then show ?thesis
    by (auto simp add: trancl_mono)
       (meson sup_ge1 sup_ge2 trancl_mono trancl_trans)
qed

text ‹Sum types where both components have the same type (to create copies)›

lemma is_InrE:
  assumes "is_Inr q"
  obtains p where "q = Inr p"
  using assms by (cases q) auto

lemma is_InlE:
  assumes "is_Inl q"
  obtains p where "q = Inl p"
  using assms by (cases q) auto

lemma not_is_Inr_is_Inl [simp]:
  "¬ is_Inl t ⟷ is_Inr t"
  "¬ is_Inr t ⟷ is_Inl t"
  by (cases t, auto)+

lemma [simp]: "remove_sum ∘ Inl = id" by auto

abbreviation CInl :: "'q ⇒ 'q + 'q" where "CInl ≡ Inl"
abbreviation CInr :: "'q ⇒ 'q + 'q" where "CInr ≡ Inr"

lemma inj_CInl: "inj CInl" "inj CInr" using inj_Inl inj_Inr by blast+

lemma map_prod_simp': "map_prod f g G = (f (fst G), g (snd G))"
  by (auto simp add: map_prod_def split!: prod.splits)

end
dy>

Theory Ground_Terms

subsection ‹Ground constructions›

theory Ground_Terms
  imports Basic_Utils
begin

subsubsection ‹Ground terms›

text ‹This type serves two purposes. First of all, the encoding definitions and proofs are not
littered by cases for variables. Secondly, we can consider tree domains (usually sets of positions),
which become a special case of ground terms. This enables the construction of a term from a
tree domain and a function from positions to symbols.›

datatype 'f gterm =
  GFun (groot_sym: 'f) (gargs: "'f gterm list")

lemma gterm_idx_induct[case_names GFun]:
  assumes "⋀ f ts. (⋀ i. i < length ts ⟹ P (ts ! i)) ⟹ P (GFun f ts)"
  shows "P t" using assms
  by (induct t) auto

fun term_of_gterm where
  "term_of_gterm (GFun f ts) = Fun f (map term_of_gterm ts)"

fun gterm_of_term where
  "gterm_of_term (Fun f ts) = GFun f (map gterm_of_term ts)"

fun groot where
  "groot (GFun f ts) = (f, length ts)"

lemma groot_sym_groot_conv:
  "groot_sym t = fst (groot t)"
  by (cases t) auto

lemma groot_sym_gterm_of_term:
  "ground t ⟹ groot_sym (gterm_of_term t) = fst (the (root t))"
  by (cases t) auto

lemma length_args_length_gargs [simp]:
  "length (args (term_of_gterm t)) = length (gargs t)"
  by (cases t) auto

lemma ground_term_of_gterm [simp]:
  "ground (term_of_gterm s)"
  by (induct s) auto

lemma ground_term_of_gterm' [simp]:
  "term_of_gterm s = Fun f ss ⟹ ground (Fun f ss)"
  by (induct s) auto

lemma term_of_gterm_inv [simp]:
  "gterm_of_term (term_of_gterm t) = t"
  by (induct t) (auto intro!: nth_equalityI)

lemma inj_term_of_gterm:
  "inj_on term_of_gterm X"
  by (metis inj_on_def term_of_gterm_inv)

lemma gterm_of_term_inv [simp]:
  "ground t ⟹ term_of_gterm (gterm_of_term t) = t"
  by (induct t) (auto 0 0 intro!: nth_equalityI)

lemma ground_term_to_gtermD:
  "ground t ⟹ ∃t'. t = term_of_gterm t'"
  by (metis gterm_of_term_inv)

lemma map_term_of_gterm [simp]:
  "map_term f g (term_of_gterm t) = term_of_gterm (map_gterm f t)"
  by (induct t) auto

lemma map_gterm_of_term [simp]:
  "ground t ⟹ gterm_of_term (map_term f g t) = map_gterm f (gterm_of_term t)"
  by (induct t) auto

lemma gterm_set_gterm_funs_terms:
  "set_gterm t = funs_term (term_of_gterm t)"
  by (induct t) auto

lemma term_set_gterm_funs_terms:
  assumes "ground t"
  shows "set_gterm (gterm_of_term t) = funs_term t"
  using assms by (induct t) auto

lemma vars_term_of_gterm [simp]:
  "vars_term (term_of_gterm t) = {}"
  by (induct t) auto

lemma vars_term_of_gterm_subseteq [simp]:
  "vars_term (term_of_gterm t) ⊆ Q ⟷ True"
  by auto

context
  notes conj_cong [fundef_cong]
begin
fun gposs :: "'f gterm ⇒ pos set" where
  "gposs (GFun f ss) = {[]} ∪ {i # p | i p. i < length ss ∧ p ∈ gposs (ss ! i)}"
end

lemma gposs_Nil [simp]: "[] ∈ gposs s"
  by (cases s) auto

lemma gposs_map_gterm [simp]:
  "gposs (map_gterm f s) = gposs s"
  by (induct s) auto

lemma poss_gposs_conv:
  "poss (term_of_gterm t) = gposs t"
  by (induct t) auto

lemma poss_gposs_mem_conv:
  "p ∈ poss (term_of_gterm t) ⟷ p ∈ gposs t"
  using poss_gposs_conv by auto

lemma gposs_to_poss:
  "p ∈ gposs t ⟹ p ∈ poss (term_of_gterm t)"
  by (simp add: poss_gposs_mem_conv)

fun gfun_at :: "'f gterm ⇒ pos ⇒ 'f option" where
  "gfun_at (GFun f ts) [] = Some f"
| "gfun_at (GFun f ts) (i # p) = (if i < length ts then gfun_at (ts ! i) p else None)"

abbreviation "exInl ≡ case_sum (λ x. x) (λ _.undefined)"

lemma gfun_at_gterm_of_term [simp]:
  "ground s ⟹ map_option exInl (fun_at s p) = gfun_at (gterm_of_term s) p"
proof (induct p arbitrary: s)
  case Nil then show ?case
    by (cases s) auto
next
  case (Cons i p) then show ?case
    by (cases s) auto
qed

lemmas gfun_at_gterm_of_term' [simp] = gfun_at_gterm_of_term[OF ground_term_of_gterm, unfolded term_of_gterm_inv]

lemma gfun_at_None_ngposs_iff: "gfun_at s p = None ⟷ p ∉ gposs s"
  by (induct rule: gfun_at.induct) auto


lemma gfun_at_map_gterm [simp]:
  "gfun_at (map_gterm f t) p = map_option f (gfun_at t p)"
  by (induct t arbitrary: p; case_tac p) (auto simp: comp_def)

lemma set_gterm_gposs_conv:
  "set_gterm t = {the (gfun_at t p) | p. p ∈ gposs t}"
proof (induct t)
  case (GFun f ts)
  note [simp] = gfun_at_gterm_of_term[OF ground_term_of_gterm, unfolded term_of_gterm_inv]
  have [simp]: "{the (map_option exInl (fun_at (Fun f (map term_of_gterm ts :: (_, unit) term list)) p)) |p.
    ∃i pa. p = i # pa ∧ i < length ts ∧ pa ∈ gposs (ts ! i)} =
    (⋃x∈{ts ! i |i. i < length ts}. {the (gfun_at x p) |p. p ∈ gposs x})" (* eww *)
    unfolding UNION_eq
  proof ((intro set_eqI iffI; elim CollectE exE bexE conjE), goal_cases lr rl)
    case (lr x p i pa) then show ?case
      by (intro CollectI[of _ x] bexI[of _ "ts ! i"] exI[of _ pa]) (auto intro!: arg_cong[where ?f = the])
  next
    case (rl x xa i p) then show ?case
      by (intro CollectI[of _ x] exI[of _ "i # p"]) auto
  qed
  have [simp]: "(⋃x∈{ts ! i |i. i < length ts}. {the (gfun_at x p) |p. p ∈ gposs x}) =
    {the (gfun_at (GFun f ts) p) |p. ∃i pa. p = i # pa ∧ i < length ts ∧ pa ∈ gposs (ts ! i)}"
    by auto (metis gfun_at.simps(2))+
  show ?case
    by (simp add: GFun(1) set_conv_nth conj_disj_distribL ex_disj_distrib Collect_disj_eq) 
qed

text ‹A @{type gterm} version of lemma @{verbatim eq_term_by_poss_fun_at}.›

lemma fun_at_gfun_at_conv:
  "fun_at (term_of_gterm s) p = fun_at (term_of_gterm t) p ⟷ gfun_at s p = gfun_at t p"
proof (induct p arbitrary: s t)
  case Nil then show ?case
    by (cases s; cases t) auto
next
  case (Cons i p)
  obtain f h ss ts where [simp]: "s = GFun f ss" "t = GFun h ts" by (cases s; cases t) auto
  have [simp]: "None = fun_at (term_of_gterm (ts ! i)) p ⟷ p ∉ gposs (ts ! i)"
    using fun_at_None_nposs_iff by (metis poss_gposs_mem_conv)
  have [simp]:"None = gfun_at (ts ! i) p ⟷ p ∉ gposs (ts ! i)"
    using gfun_at_None_ngposs_iff by force
  show ?case using Cons[of "gargs s ! i" "gargs t ! i"]
    by (auto simp: poss_gposs_conv gfun_at_None_ngposs_iff fun_at_None_nposs_iff
       intro!: iffD2[OF gfun_at_None_ngposs_iff] iffD2[OF fun_at_None_nposs_iff])
qed

lemmas eq_gterm_by_gposs_gfun_at = arg_cong[where f = gterm_of_term,
  OF eq_term_by_poss_fun_at[of "term_of_gterm s :: (_, unit) term" "term_of_gterm t :: (_, unit) term" for s t],
  unfolded term_of_gterm_inv poss_gposs_conv fun_at_gfun_at_conv]

fun gsubt_at :: "'f gterm ⇒ pos ⇒ 'f gterm" where
  "gsubt_at s [] = s" |
  "gsubt_at (GFun f ss) (i # p) = gsubt_at (ss ! i) p"

lemma gsubt_at_to_subt_at:
  assumes "p ∈ gposs s"
  shows "gterm_of_term (term_of_gterm s |_ p) = gsubt_at s p"
  using assms by (induct arbitrary: p) (auto simp add: map_idI)

lemma term_of_gterm_gsubt:
  assumes "p ∈ gposs s"
  shows "(term_of_gterm s) |_ p = term_of_gterm (gsubt_at s p)"
  using assms by (induct arbitrary: p) auto

lemma gsubt_at_gposs [simp]:
  assumes "p ∈ gposs s"
  shows "gposs (gsubt_at s p) = {x | x. p @ x ∈ gposs s}"
  using assms by (induct s arbitrary: p) auto

lemma gfun_at_gsub_at [simp]:
  assumes "p ∈ gposs s" and "p @ q ∈ gposs s"
  shows "gfun_at (gsubt_at s p) q = gfun_at s (p @ q)"
  using assms by (induct s arbitrary: p q) auto

lemma gposs_gsubst_at_subst_at_eq [simp]:
  assumes "p ∈ gposs s"
  shows "gposs (gsubt_at s p) = poss (term_of_gterm s |_ p)" using assms
proof (induct s arbitrary: p)
  case (GFun f ts)
  show ?case using GFun(1)[OF nth_mem] GFun(2-)
    by (auto simp: poss_gposs_mem_conv) blast+
qed

lemma gpos_append_gposs:
  assumes "p ∈ gposs t" and "q ∈ gposs (gsubt_at t p)"
  shows "p @ q ∈ gposs t"
  using assms by auto


text ‹Replace terms at position›

fun replace_gterm_at ("_[_ ← _]G" [1000, 0, 0] 1000) where
  "replace_gterm_at s [] t = t"
| "replace_gterm_at (GFun f ts) (i # ps) t =
    (if i < length ts then GFun f (ts[i:=(replace_gterm_at (ts ! i) ps t)]) else GFun f ts)"

lemma replace_gterm_at_not_poss [simp]:
  "p ∉ gposs s ⟹ s[p ← t]G = s"
proof (induct s arbitrary: p)
  case (GFun f ts) show ?case using GFun(1)[OF nth_mem] GFun(2)
    by (cases p) (auto simp: min_def intro!: nth_equalityI)
qed

lemma parallel_replace_gterm_commute [ac_simps]:
  "p ⊥ q ⟹ s[p ← t]G[q ← u]G = s[q ← u]G[p ← t]G"
proof (induct s arbitrary: p q)
  case (GFun f ts)
  from GFun(2) have "p ≠ []" "q ≠ []" by auto
  then obtain i j ps qs where [simp]: "p = i # ps" "q = j # qs"
    by (cases p; cases q) auto
  have "i ≠ j ⟹ (GFun f ts)[p ← t]G[q ← u]G = (GFun f ts)[q ← u]G[p ← t]G"
    by (auto simp: list_update_swap)
  then show ?case using GFun(1)[OF nth_mem, of j ps qs] GFun(2)
    by (cases "i = j") (auto simp: par_Cons_iff)
qed

lemma replace_gterm_at_above [simp]:
  "p ≤p q ⟹ s[q ← t]G[p ← u]G = s[p ← u]G"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "tl q" "gargs s ! i"] Cons(2)
    by (cases q; cases s) auto
qed auto

lemma replace_gterm_at_below [simp]:
  "p <p q ⟹ s[p ← t]G[q ← u]G = s[p ← t[q -p p ← u]G]G"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "tl q" "gargs s ! i"] Cons(2)
    by (cases q; cases s) auto
qed auto

lemma groot_sym_replace_gterm [simp]:
  "p ≠ [] ⟹ groot_sym s[p ← t]G = groot_sym s"
  by (cases s; cases p) auto

lemma replace_gterm_gsubt_at_id [simp]: "s[p ← gsubt_at s p]G = s"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) auto
qed auto

lemma replace_gterm_conv:
  "p ∈ gposs s ⟹ (term_of_gterm s)[p ← (term_of_gterm t)] = term_of_gterm (s[p ← t]G)"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) (auto simp: nth_list_update intro: nth_equalityI)
qed auto

subsubsection ‹Tree domains›

type_synonym gdomain = "unit gterm"

abbreviation gdomain where
  "gdomain ≡ map_gterm (λ_. ())"

lemma gdomain_id:
  "gdomain t = t"
proof -
  have [simp]: "(λ_. ()) = id" by auto
  then show ?thesis by (simp add: gterm.map_id)
qed

lemma gdomain_gsubt [simp]:
  assumes "p ∈ gposs t"
  shows "gdomain (gsubt_at t p) = gsubt_at (gdomain t) p"
  using assms by (induct t arbitrary: p) auto

text ‹Union of tree domains›

fun gunion :: "gdomain ⇒ gdomain ⇒ gdomain" where
  "gunion (GFun f ss) (GFun g ts) = GFun () (map (λi.
    if i < length ss then if i < length ts then gunion (ss ! i) (ts ! i)
    else ss ! i else ts ! i) [0..<max (length ss) (length ts)])"

lemma gposs_gunion [simp]:
  "gposs (gunion s t) = gposs s ∪ gposs t"
  by (induct s t rule: gunion.induct) (auto simp: less_max_iff_disj split: if_splits)

lemma gunion_unit [simp]:
  "gunion s (GFun () []) = s" "gunion (GFun () []) s = s"
  by (cases s, (auto intro!: nth_equalityI)[1])+

lemma gunion_gsubt_at_nt_poss1:
  assumes "p ∈ gposs s" and "p ∉ gposs t"
  shows "gsubt_at (gunion s t) p = gsubt_at s p"
  using assms by (induct s arbitrary: p t) (case_tac p; case_tac t, auto)


lemma gunion_gsubt_at_nt_poss2:
  assumes "p ∈ gposs t" and "p ∉ gposs s"
  shows "gsubt_at (gunion s t) p = gsubt_at t p"
  using assms by (induct t arbitrary: p s) (case_tac p; case_tac s, auto)

lemma gunion_gsubt_at_poss:
  assumes "p ∈ gposs s" and "p ∈ gposs t"
  shows "gunion (gsubt_at s p) (gsubt_at t p) = gsubt_at (gunion s t) p"
  using assms
proof (induct p arbitrary: s t)
  case (Cons a p)
  then show ?case by (cases s; cases t) auto 
qed auto 

lemma gfun_at_domain:
  shows "gfun_at t p = (if p ∈ gposs t then Some () else None)"
proof (induct t arbitrary: p)
  case (GFun f ts) then show ?case
    by (cases p) auto
qed

lemma gunion_assoc [ac_simps]:
  "gunion s (gunion t u) = gunion (gunion s t) u"
  by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gfun_at_domain poss_gposs_mem_conv)

lemma gunion_commute [ac_simps]:
  "gunion s t = gunion t s"
  by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gfun_at_domain poss_gposs_mem_conv)

lemma gunion_idemp [simp]:
  "gunion s s = s"
  by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gfun_at_domain poss_gposs_mem_conv)

definition gunions :: "gdomain list ⇒ gdomain" where
  "gunions ts = foldr gunion ts (GFun () [])"

lemma gunions_append:
  "gunions (ss @ ts) = gunion (gunions ss) (gunions ts)"
  by (induct ss) (auto simp: gunions_def gunion_assoc)

lemma gposs_gunions [simp]:
  "gposs (gunions ts) = {[]} ∪ ⋃{gposs t |t. t ∈ set ts}"
  by (induct ts) (auto simp: gunions_def)


text ‹Given a tree domain and a function from positions to symbols, we can construct a term.›
context
  notes conj_cong [fundef_cong]
begin
fun glabel :: "(pos ⇒ 'f) ⇒ gdomain ⇒ 'f gterm" where
  "glabel h (GFun f ts) = GFun (h []) (map (λi. glabel (h ∘ (#) i) (ts ! i)) [0..<length ts])"
end

lemma map_gterm_glabel:
  "map_gterm f (glabel h t) = glabel (f ∘ h) t"
  by (induct t arbitrary: h) (auto simp: comp_def)

lemma gfun_at_glabel [simp]:
  "gfun_at (glabel f t) p = (if p ∈ gposs t then Some (f p) else None)"
  by (induct t arbitrary: f p, case_tac p) (auto simp: comp_def)

lemma gposs_glabel [simp]:
  "gposs (glabel f t) = gposs t"
  by (induct t arbitrary: f) auto

lemma glabel_map_gterm_conv:
  "glabel (f ∘ gfun_at t) (gdomain t) = map_gterm (f ∘ Some) t"
  by (induct t) (auto simp: comp_def intro!: nth_equalityI)

lemma gfun_at_nongposs [simp]:
  "p ∉ gposs t ⟹ gfun_at t p = None"
  using gfun_at_glabel[of "the ∘ gfun_at t" "gdomain t" p, unfolded glabel_map_gterm_conv]
  by (simp add: comp_def option.map_ident)

lemma gfun_at_poss:
  "p ∈ gposs t ⟹ ∃f. gfun_at t p = Some f"
  using gfun_at_glabel[of "the ∘ gfun_at t" "gdomain t" p, unfolded glabel_map_gterm_conv]
  by (auto simp: comp_def)

lemma gfun_at_possE:
  assumes "p ∈ gposs t"
  obtains f where "gfun_at t p = Some f"
  using assms gfun_at_poss by blast

lemma gfun_at_poss_gpossD:
  "gfun_at t p = Some f ⟹ p ∈ gposs t"
  by (metis gfun_at_nongposs option.distinct(1))

text ‹function symbols of a ground term›

primrec funas_gterm :: "'f gterm ⇒ ('f × nat) set" where
  "funas_gterm (GFun f ts) = {(f, length ts)} ∪ ⋃(set (map funas_gterm ts))"

lemma funas_gterm_gterm_of_term:
  "ground t ⟹ funas_gterm (gterm_of_term t) = funas_term t"
  by (induct t) (auto simp: funas_gterm_def)

lemma funas_term_of_gterm_conv:
  "funas_term (term_of_gterm t) = funas_gterm t"
  by (induct t) (auto simp: funas_gterm_def)

lemma funas_gterm_map_gterm:
  assumes "funas_gterm t ⊆ ℱ"
  shows "funas_gterm (map_gterm f t) ⊆ (λ (h, n). (f h, n)) ` ℱ"
  using assms by (induct t) (auto simp: funas_gterm_def)

lemma gterm_of_term_inj:
  assumes "⋀ t. t ∈ S ⟹ ground t"
  shows "inj_on gterm_of_term S"
  using assms gterm_of_term_inv by (fastforce simp: inj_on_def)

lemma funas_gterm_gsubt_at_subseteq:
  assumes "p ∈ gposs s"
  shows "funas_gterm (gsubt_at s p) ⊆ funas_gterm s" using assms
  apply (induct s arbitrary: p) apply auto
  using nth_mem by blast+

lemma finite_funas_gterm: "finite (funas_gterm t)"
  by (induct t) auto

text ‹ground term set›

abbreviation gterms where
  "gterms ℱ ≡ {s. funas_gterm s ⊆ ℱ}"

lemma gterms_mono:
  "𝒢 ⊆ ℱ ⟹ gterms 𝒢 ⊆ gterms ℱ"
  by auto

inductive_set 𝒯G for ℱ where
  const [simp]: "(a, 0) ∈ ℱ ⟹ GFun a [] ∈ 𝒯G ℱ"
| ind [intro]: "(f, n) ∈ ℱ ⟹ length ss = n ⟹ (⋀ i. i < length ss ⟹ ss ! i ∈ 𝒯G ℱ) ⟹ GFun f ss ∈ 𝒯G ℱ"

lemma 𝒯G_sound:
  "s ∈ 𝒯G ℱ ⟹ funas_gterm s ⊆ ℱ"
proof (induct)
  case (GFun f ts)
  show ?case using GFun(1)[OF nth_mem] GFun(2)
    by (fastforce simp: in_set_conv_nth elim!: 𝒯G.cases intro: nth_mem)
qed

lemma 𝒯G_complete:
  "funas_gterm s ⊆ ℱ ⟹ s ∈ 𝒯G ℱ "
  by (induct s) (auto simp: SUP_le_iff)

lemma 𝒯G_funas_gterm_conv:
  "s ∈ 𝒯G ℱ ⟷ funas_gterm s ⊆ ℱ"
  using 𝒯G_sound 𝒯G_complete by auto

lemma 𝒯G_equivalent_def:
  "𝒯G ℱ = gterms ℱ"
  using 𝒯G_funas_gterm_conv by auto

lemma 𝒯G_intersection [simp]:
  "s ∈ 𝒯G ℱ ⟹ s ∈ 𝒯G 𝒢 ⟹ s ∈ 𝒯G (ℱ ∩ 𝒢)"
  by (auto simp: 𝒯G_funas_gterm_conv 𝒯G_equivalent_def)

lemma 𝒯G_mono:
  "𝒢 ⊆ ℱ ⟹ 𝒯G 𝒢 ⊆ 𝒯G ℱ"
  using gterms_mono by (simp add: 𝒯G_equivalent_def)

lemma 𝒯G_UNIV [simp]: "s ∈ 𝒯G UNIV"
  by (induct) auto

definition funas_grel where
  "funas_grel ℛ = ⋃ ((λ (s, t). funas_gterm s ∪ funas_gterm t) ` ℛ)"

end
>

Theory FSet_Utils

theory FSet_Utils                                      
  imports "HOL-Library.FSet"
    "HOL-Library.List_Lexorder"
    Ground_Terms
begin

context
includes fset.lifting
begin

lift_definition fCollect :: "('a ⇒ bool) ⇒ 'a fset" is "λ P. if finite (Collect P) then Collect P else {}"
  by auto

lift_definition fSigma :: "'a fset ⇒ ('a ⇒ 'b fset) ⇒ ('a × 'b) fset" is Sigma
  by auto

lift_definition is_fempty :: "'a fset ⇒ bool" is Set.is_empty .
lift_definition fremove :: "'a ⇒ 'a fset ⇒ 'a fset" is Set.remove
  by (simp add: remove_def)

lift_definition finj_on :: "('a ⇒ 'b) ⇒ 'a fset ⇒ bool" is inj_on .
lift_definition the_finv_into  :: "'a fset ⇒ ('a ⇒ 'b) ⇒ 'b ⇒ 'a" is the_inv_into .

lemma fCollect_memberI [intro!]:
  "finite (Collect P) ⟹ P x ⟹ x |∈| fCollect P"
  by transfer auto

lemma fCollect_member [iff]:
  "x |∈| fCollect P ⟷ finite (Collect P) ∧ P x"
  by transfer (auto split: if_splits)

lemma fCollect_cong: "(⋀x. P x = Q x) ⟹ fCollect P = fCollect Q"
  by presburger
end

syntax
  "_fColl" :: "pttrn ⇒ bool ⇒ 'a set"    ("(1{|_./ _|})")
translations
  "{|x. P|}" ⇌ "CONST fCollect (λx. P)"

syntax (ASCII)
  "_fCollect" :: "pttrn ⇒ 'a set ⇒ bool ⇒ 'a set"  ("(1{(_/|:| _)./ _})")
syntax
  "_fCollect" :: "pttrn ⇒ 'a set ⇒ bool ⇒ 'a set"  ("(1{(_/ |∈| _)./ _})")
translations
  "{p|:|A. P}" ⇀ "CONST fCollect (λp. p |∈| A ∧ P)"

syntax (ASCII)
  "_fBall"       :: "pttrn ⇒ 'a set ⇒ bool ⇒ bool"      ("(3ALL (_/|:|_)./ _)" [0, 0, 10] 10)
  "_fBex"        :: "pttrn ⇒ 'a set ⇒ bool ⇒ bool"      ("(3EX (_/|:|_)./ _)" [0, 0, 10] 10)

syntax (input)
  "_fBall"       :: "pttrn ⇒ 'a set ⇒ bool ⇒ bool"      ("(3! (_/|:|_)./ _)" [0, 0, 10] 10)
  "_fBex"        :: "pttrn ⇒ 'a set ⇒ bool ⇒ bool"      ("(3? (_/|:|_)./ _)" [0, 0, 10] 10)

syntax
  "_fBall"       :: "pttrn ⇒ 'a set ⇒ bool ⇒ bool"      ("(3∀(_/|∈|_)./ _)" [0, 0, 10] 10)
  "_fBex"        :: "pttrn ⇒ 'a set ⇒ bool ⇒ bool"      ("(3∃(_/|∈|_)./ _)" [0, 0, 10] 10)

translations
  "∀x|∈|A. P" ⇌ "CONST fBall A (λx. P)"
  "∃x|∈|A. P" ⇌ "CONST fBex A (λx. P)"

syntax (ASCII output)
  "_setlessfAll" :: "[idt, 'a, bool] ⇒ bool"  ("(3ALL _|<|_./ _)"  [0, 0, 10] 10)
  "_setlessfEx"  :: "[idt, 'a, bool] ⇒ bool"  ("(3EX _|<|_./ _)"  [0, 0, 10] 10)
  "_setlefAll"   :: "[idt, 'a, bool] ⇒ bool"  ("(3ALL _|<=|_./ _)" [0, 0, 10] 10)
  "_setlefEx"    :: "[idt, 'a, bool] ⇒ bool"  ("(3EX _|<=|_./ _)" [0, 0, 10] 10)

syntax
  "_setlessfAll" :: "[idt, 'a, bool] ⇒ bool"   ("(3∀_|⊂|_./ _)"  [0, 0, 10] 10)
  "_setlessfEx"  :: "[idt, 'a, bool] ⇒ bool"   ("(3∃_|⊂|_./ _)"  [0, 0, 10] 10)
  "_setlefAll"   :: "[idt, 'a, bool] ⇒ bool"   ("(3∀_|⊆|_./ _)" [0, 0, 10] 10)
  "_setlefEx"    :: "[idt, 'a, bool] ⇒ bool"   ("(3∃_|⊆|_./ _)" [0, 0, 10] 10)

translations
 "∀A|⊂|B. P" ⇀ "∀A. A |⊂| B ⟶ P"
 "∃A|⊂|B. P" ⇀ "∃A. A |⊂| B ∧ P"
 "∀A|⊆|B. P" ⇀ "∀A. A |⊆| B ⟶ P"
 "∃A|⊆|B. P" ⇀ "∃A. A |⊆| B ∧ P"

syntax
  "_fSetcompr" :: "'a ⇒ idts ⇒ bool ⇒ 'a fset"    ("(1{|_ |/_./ _|})")

parse_translation ‹
  let
    val ex_tr = snd (Syntax_Trans.mk_binder_tr ("EX ", const_syntax‹Ex›));

    fun nvars (Const (syntax_const‹_idts›, _) $ _ $ idts) = nvars idts + 1
      | nvars _ = 1;

    fun setcompr_tr ctxt [e, idts, b] =
      let
        val eq = Syntax.const const_syntax‹HOL.eq› $ Bound (nvars idts) $ e;
        val P = Syntax.const const_syntax‹HOL.conj› $ eq $ b;
        val exP = ex_tr ctxt [idts, P];
      in Syntax.const const_syntax‹fCollect› $ absdummy dummyT exP end;

  in [(syntax_const‹_fSetcompr›, setcompr_tr)] end
›

print_translation ‹
 [Syntax_Trans.preserve_binder_abs2_tr' const_syntax‹fBall› syntax_const‹_fBall›,
  Syntax_Trans.preserve_binder_abs2_tr' const_syntax‹fBex› syntax_const‹_fBex›]
› ― ‹to avoid eta-contraction of body›

print_translation ‹
let
  val ex_tr' = snd (Syntax_Trans.mk_binder_tr' (const_syntax‹Ex›, "DUMMY"));

  fun setcompr_tr' ctxt [Abs (abs as (_, _, P))] =
    let
      fun check (Const (const_syntax‹Ex›, _) $ Abs (_, _, P), n) = check (P, n + 1)
        | check (Const (const_syntax‹HOL.conj›, _) $
              (Const (const_syntax‹HOL.eq›, _) $ Bound m $ e) $ P, n) =
            n > 0 andalso m = n andalso not (loose_bvar1 (P, n)) andalso
            subset (=) (0 upto (n - 1), add_loose_bnos (e, 0, []))
        | check _ = false;

        fun tr' (_ $ abs) =
          let val _ $ idts $ (_ $ (_ $ _ $ e) $ Q) = ex_tr' ctxt [abs]
          in Syntax.const syntax_const‹_fSetcompr› $ e $ idts $ Q end;
    in
      if check (P, 0) then tr' P
      else
        let
          val (x as _ $ Free(xN, _), t) = Syntax_Trans.atomic_abs_tr' abs;
          val M = Syntax.const syntax_const‹_fColl› $ x $ t;
        in
          case t of
            Const (const_syntax‹HOL.conj›, _) $
              (Const (const_syntax‹fmember›, _) $
                (Const (syntax_const‹_bound›, _) $ Free (yN, _)) $ A) $ P =>
            if xN = yN then Syntax.const syntax_const‹_fCollect› $ x $ A $ P else M
          | _ => M
        end
    end;
  in [(const_syntax‹fCollect›, setcompr_tr')] end
›

syntax
  "_fSigma" :: "pttrn ⇒ 'a fset ⇒ 'b fset ⇒ ('a × 'b) set"  ("(3fSIGMA _|:|_./ _)" [0, 0, 10] 10)
translations
  "fSIGMA x|:|A. B" ⇌ "CONST fSigma A (λx. B)"

notation
  ffUnion ("|⋃|")

context
includes fset.lifting
begin

lemma right_total_cr_fset [transfer_rule]:
  "right_total cr_fset"
  by (auto simp: cr_fset_def right_total_def)

lemma bi_unique_cr_fset [transfer_rule]:
  "bi_unique cr_fset"
  by (auto simp: bi_unique_def cr_fset_def fset_inject)

lemma right_total_pcr_fset_eq [transfer_rule]:
  "right_total (pcr_fset (=))"
  by (simp add: right_total_cr_fset fset.pcr_cr_eq)

lemma bi_unique_pcr_fset [transfer_rule]:
  "bi_unique (pcr_fset (=))"
  by (simp add: fset.pcr_cr_eq bi_unique_cr_fset)


lemma set_fset_of_list_transfer [transfer_rule]:
  "rel_fun (list_all2 A) (pcr_fset A) set fset_of_list"
  unfolding pcr_fset_def rel_set_def rel_fun_def
  by (force simp: list_all2_conv_all_nth in_set_conv_nth cr_fset_def fset_of_list.rep_eq relcompp_apply)
  

lemma fCollectD: "a |∈| {|x . P x|} ⟹ P a"
  by transfer (auto split: if_splits)

lemma fCollectI: "P a ⟹ finite (Collect P) ⟹ a |∈| {| x. P x|}"
  by (auto intro: fCollect_memberI)

lemma fCollect_fempty_eq [simp]: "fCollect P = {||} ⟷ (∀x. ¬ P x) ∨ infinite (Collect P)"
  by auto

lemma fempty_fCollect_eq [simp]: "{||} = fCollect P ⟷ (∀x. ¬ P x) ∨ infinite (Collect P)"
  by auto


lemma fset_image_conv:
  "{f x | x. x |∈| T} = fset (f |`| T)"
  by transfer auto

lemma fimage_def:
  "f |`| A = {| y. ∃x|∈|A. y = f x |}"
  by transfer auto

lemma ffilter_simp: "ffilter P A = {a |∈| A. P a}"
  by transfer auto

lemmas fset_list_fsubset_eq_nth_conv = set_list_subset_eq_nth_conv[Transfer.transferred]
lemmas mem_idx_fset_sound = mem_idx_sound[Transfer.transferred]
― ‹Dealing with fset products›

abbreviation fTimes :: "'a fset ⇒ 'b fset ⇒ ('a × 'b) fset"  (infixr "|×|" 80)
  where "A |×| B ≡ fSigma A (λ_. B)"

lemma fSigma_repeq:
  "fset (A |×| B) = fset A × fset B"
  by (transfer) auto

lemmas fSigmaI [intro!] = SigmaI[Transfer.transferred]
lemmas fSigmaE [elim!] = SigmaE[Transfer.transferred]
lemmas fSigmaD1 = SigmaD1[Transfer.transferred]
lemmas fSigmaD2 = SigmaD2[Transfer.transferred]
lemmas fSigmaE2 = SigmaE2[Transfer.transferred]
lemmas fSigma_cong = Sigma_cong[Transfer.transferred]
lemmas fSigma_mono = Sigma_mono[Transfer.transferred]
lemmas fSigma_empty1 [simp] = Sigma_empty1[Transfer.transferred]
lemmas fSigma_empty2 [simp] = Sigma_empty2[Transfer.transferred]
lemmas fmem_Sigma_iff [iff] = mem_Sigma_iff[Transfer.transferred]
lemmas fmem_Times_iff = mem_Times_iff[Transfer.transferred]
lemmas fSigma_empty_iff = Sigma_empty_iff[Transfer.transferred]
lemmas fTimes_subset_cancel2 = Times_subset_cancel2[Transfer.transferred]
lemmas fTimes_eq_cancel2 = Times_eq_cancel2[Transfer.transferred]
lemmas fUN_Times_distrib = UN_Times_distrib[Transfer.transferred]
lemmas fsplit_paired_Ball_Sigma [simp, no_atp] = split_paired_Ball_Sigma[Transfer.transferred]
lemmas fsplit_paired_Bex_Sigma [simp, no_atp] = split_paired_Bex_Sigma[Transfer.transferred]
lemmas fSigma_Un_distrib1 = Sigma_Un_distrib1[Transfer.transferred]
lemmas fSigma_Un_distrib2 = Sigma_Un_distrib2[Transfer.transferred]
lemmas fSigma_Int_distrib1 = Sigma_Int_distrib1[Transfer.transferred]
lemmas fSigma_Int_distrib2 = Sigma_Int_distrib2[Transfer.transferred]
lemmas fSigma_Diff_distrib1 = Sigma_Diff_distrib1[Transfer.transferred]
lemmas fSigma_Diff_distrib2 = Sigma_Diff_distrib2[Transfer.transferred]
lemmas fSigma_Union = Sigma_Union[Transfer.transferred]
lemmas fTimes_Un_distrib1 = Times_Un_distrib1[Transfer.transferred]
lemmas fTimes_Int_distrib1 = Times_Int_distrib1[Transfer.transferred]
lemmas fTimes_Diff_distrib1 = Times_Diff_distrib1[Transfer.transferred]
lemmas fTimes_empty [simp] = Times_empty[Transfer.transferred]
lemmas ftimes_subset_iff = times_subset_iff[Transfer.transferred]
lemmas ftimes_eq_iff = times_eq_iff[Transfer.transferred]
lemmas ffst_image_times [simp] = fst_image_times[Transfer.transferred]
lemmas fsnd_image_times [simp] = snd_image_times[Transfer.transferred]
lemmas fsnd_image_Sigma = snd_image_Sigma[Transfer.transferred]
lemmas finsert_Times_insert = insert_Times_insert[Transfer.transferred]
lemmas fTimes_Int_Times = Times_Int_Times[Transfer.transferred]
lemmas fimage_paired_Times = image_paired_Times[Transfer.transferred]
lemmas fproduct_swap = product_swap[Transfer.transferred]
lemmas fswap_product = swap_product[Transfer.transferred]
lemmas fsubset_fst_snd = subset_fst_snd[Transfer.transferred]
lemmas map_prod_ftimes = map_prod_times[Transfer.transferred]


lemma fCollect_case_prod [simp]:
  "{|(a, b). P a ∧ Q b|} = fCollect P |×| fCollect Q"
  by transfer (auto dest: finite_cartesian_productD1 finite_cartesian_productD2)
lemma fCollect_case_prodD:
  "x |∈| {|(x, y). A x y|} ⟹ A (fst x) (snd x)"
  by auto


(*FIX *)
lemmas fCollect_case_prod_Sigma = Collect_case_prod_Sigma[Transfer.transferred]
lemmas ffst_image_Sigma = fst_image_Sigma[Transfer.transferred]
lemmas fimage_split_eq_Sigma = image_split_eq_Sigma[Transfer.transferred]


― ‹Dealing with transitive closure›

lift_definition ftrancl :: "('a × 'a) fset ⇒ ('a × 'a) fset"  ("(_|+|)" [1000] 999) is trancl
  by auto

lemmas fr_into_trancl [intro, Pure.intro] = r_into_trancl[Transfer.transferred]
lemmas ftrancl_into_trancl [Pure.intro] = trancl_into_trancl[Transfer.transferred]
lemmas ftrancl_induct[consumes 1, case_names Base Step] = trancl.induct[Transfer.transferred]
lemmas ftrancl_mono = trancl_mono[Transfer.transferred]
lemmas ftrancl_trans[trans] = trancl_trans[Transfer.transferred]
lemmas ftrancl_empty [simp] = trancl_empty [Transfer.transferred]
lemmas ftranclE[cases set: ftrancl] = tranclE[Transfer.transferred]
lemmas converse_ftrancl_induct[consumes 1, case_names Base Step] = converse_trancl_induct[Transfer.transferred]
lemmas converse_ftranclE = converse_tranclE[Transfer.transferred]
lemma in_ftrancl_UnI:
  "x |∈| R|+| ∨ x |∈| S|+| ⟹ x |∈| (R |∪| S)|+|"
  by transfer (auto simp add: trancl_mono)

lemma ftranclD:
  "(x, y) |∈| R|+| ⟹ ∃z. (x, z) |∈| R ∧ (z = y ∨ (z, y) |∈| R|+|)"
  by (induct rule: ftrancl_induct) (auto, meson ftrancl_into_trancl)

lemma ftranclD2:
  "(x, y) |∈| R|+| ⟹ ∃z. (x = z ∨ (x, z) |∈| R|+|) ∧ (z, y) |∈| R"
  by (induct rule: ftrancl_induct) auto

lemma not_ftrancl_into:
  "(x, z) |∉| r|+| ⟹ (y, z) |∈| r ⟹ (x, y) |∉| r|+|"
  by transfer (auto simp add: trancl.trancl_into_trancl)
lemmas ftrancl_map_both_fRestr = trancl_map_both_Restr[Transfer.transferred]
lemma ftrancl_map_both_fsubset:
  "finj_on f X ⟹ R |⊆| X |×| X ⟹ (map_both f |`| R)|+| = map_both f |`| R|+|"
  using ftrancl_map_both_fRestr[of f X R]
  by (simp add: inf_absorb1)
lemmas ftrancl_map_prod_mono = trancl_map_prod_mono[Transfer.transferred]
lemmas ftrancl_map = trancl_map[Transfer.transferred]


lemmas ffUnion_iff [simp] = Union_iff[Transfer.transferred]
lemmas ffUnionI [intro] = UnionI[Transfer.transferred]
lemmas fUn_simps [simp] = UN_simps[Transfer.transferred]


(* TODO Diff *)
lemmas fINT_simps [simp] = INT_simps[Transfer.transferred]

lemmas fUN_ball_bex_simps [simp] = UN_ball_bex_simps[Transfer.transferred]

(* List *)
lemmas in_fset_conv_nth = in_set_conv_nth[Transfer.transferred]
lemmas fnth_mem [simp] = nth_mem[Transfer.transferred]
lemmas distinct_sorted_list_of_fset = distinct_sorted_list_of_set [Transfer.transferred]
lemmas fcard_fset = card_set[Transfer.transferred]
lemma upt_fset:
  "fset_of_list [i..<j] = fCollect (λ n. i ≤ n ∧ n < j)"
  by (induct j arbitrary: i) auto

(* Restr *)
abbreviation fRestr :: "('a × 'a) fset ⇒ 'a fset ⇒ ('a × 'a) fset" where
  "fRestr r A ≡ r |∩| (A |×| A)"

(* Identity on set*)

lift_definition fId_on :: "'a fset ⇒ ('a × 'a) fset" is Id_on
  using Id_on_subset_Times finite_subset by fastforce

lemmas fId_on_empty [simp] = Id_on_empty [Transfer.transferred]
lemmas fId_on_eqI = Id_on_eqI [Transfer.transferred]
lemmas fId_onI [intro!] = Id_onI [Transfer.transferred]
lemmas fId_onE [elim!] = Id_onE [Transfer.transferred]
lemmas fId_on_iff = Id_on_iff [Transfer.transferred]
lemmas fId_on_fsubset_fTimes = Id_on_subset_Times [Transfer.transferred]

(* Converse*)
lift_definition fconverse :: "('a × 'b) fset ⇒ ('b × 'a) fset"  ("(_|¯|)" [1000] 999) is converse by auto

lemmas fconverseI [sym] = converseI [Transfer.transferred]
lemmas fconverseD [sym] = converseD [Transfer.transferred]
lemmas fconverseE [elim!] = converseE [Transfer.transferred]
lemmas fconverse_iff [iff] = converse_iff[Transfer.transferred]
lemmas fconverse_fconverse [simp] = converse_converse[Transfer.transferred]
lemmas fconverse_empty[simp] = converse_empty[Transfer.transferred]

(* injectivity *)

lemmas finj_on_def' = inj_on_def[Transfer.transferred]
lemmas fsubset_finj_on = subset_inj_on[Transfer.transferred]
lemmas the_finv_into_f_f = the_inv_into_f_f[Transfer.transferred]
lemmas f_the_finv_into_f = f_the_inv_into_f[Transfer.transferred]
lemmas the_finv_into_into = the_inv_into_into[Transfer.transferred]
lemmas the_finv_into_onto [simp] = the_inv_into_onto[Transfer.transferred]
lemmas the_finv_into_f_eq = the_inv_into_f_eq[Transfer.transferred]
lemmas the_finv_into_comp = the_inv_into_comp[Transfer.transferred]
lemmas finj_on_the_finv_into = inj_on_the_inv_into [Transfer.transferred]
lemmas finj_on_fUn = inj_on_Un[Transfer.transferred]

lemma finj_Inl_Inr:
  "finj_on Inl A" "finj_on Inr A"
  by (transfer, auto)+
lemma finj_CInl_CInr:
  "finj_on CInl A" "finj_on CInr A"
  using finj_Inl_Inr by force+

lemma finj_Some:
  "finj_on Some A"
  by (transfer, auto)

(* Image *)

lift_definition fImage :: "('a × 'b) fset ⇒ 'a fset ⇒ 'b fset" (infixr "|``|" 90) is Image
  using finite_Image by force

lemmas fImage_iff = Image_iff[Transfer.transferred]
lemmas fImage_singleton_iff [iff] = Image_singleton_iff[Transfer.transferred]
lemmas fImageI [intro] = ImageI[Transfer.transferred]
lemmas ImageE [elim!] = ImageE[Transfer.transferred]
lemmas frev_ImageI = rev_ImageI[Transfer.transferred]
lemmas fImage_empty1 [simp] = Image_empty1[Transfer.transferred]
lemmas fImage_empty2 [simp] = Image_empty2[Transfer.transferred]
lemmas fImage_fInt_fsubset = Image_Int_subset[Transfer.transferred]
lemmas fImage_fUn = Image_Un[Transfer.transferred]
lemmas fUn_fImage = Un_Image[Transfer.transferred]
lemmas fImage_fsubset = Image_subset[Transfer.transferred]
lemmas fImage_eq_fUN = Image_eq_UN[Transfer.transferred]
lemmas fImage_mono = Image_mono[Transfer.transferred]
lemmas fImage_fUN = Image_UN[Transfer.transferred]
lemmas fUN_fImage = UN_Image[Transfer.transferred]
lemmas fSigma_fImage = Sigma_Image[Transfer.transferred]


(* fix us *)
lemmas fImage_singleton = Image_singleton[Transfer.transferred]
lemmas fImage_Id_on [simp] = Image_Id_on[Transfer.transferred]
lemmas fImage_Id [simp] = Image_Id[Transfer.transferred]
lemmas fImage_fInt_eq = Image_Int_eq[Transfer.transferred]
lemmas fImage_fsubset_eq = Image_subset_eq[Transfer.transferred]
lemmas fImage_fCollect_case_prod [simp] = Image_Collect_case_prod[Transfer.transferred]
lemmas fImage_fINT_fsubset = Image_INT_subset[Transfer.transferred]
(* Misc *)
lemmas term_fset_induct = term.induct[Transfer.transferred]
lemmas fmap_prod_fimageI = map_prod_imageI[Transfer.transferred]
lemmas finj_on_eq_iff = inj_on_eq_iff[Transfer.transferred]
lemmas prod_fun_fimageE = prod_fun_imageE[Transfer.transferred]

lemma rel_set_cr_fset:
  "rel_set cr_fset = (λ A B. A = fset ` B)"
proof -
  have "rel_set cr_fset A B ⟷ A = fset ` B" for A B
    by (auto simp: image_def rel_set_def cr_fset_def )
  then show ?thesis by blast
qed
lemma pcr_fset_cr_fset:
  "pcr_fset cr_fset = (λ x y. x = fset (fset |`| y))"
  unfolding pcr_fset_def rel_set_cr_fset
  unfolding cr_fset_def
  by (auto simp: image_def relcompp_apply)


lemma sorted_list_of_fset_id:
  "sorted_list_of_fset x = sorted_list_of_fset y ⟹ x = y"
  by (metis sorted_list_of_fset_simps(2))

(*end *)

lemmas fBall_def = Ball_def[Transfer.transferred]
lemmas fBex_def = Bex_def[Transfer.transferred]
lemmas fCollectE = fCollectD [elim_format]
lemma fCollect_conj_eq:
  "finite (Collect P) ⟹ finite (Collect Q) ⟹ {|x. P x ∧ Q x|} = fCollect P |∩| fCollect Q"
  by auto

lemma finite_ntrancl:
  "finite R ⟹ finite (ntrancl n R)"
  by (induct n) auto

lift_definition nftrancl :: "nat ⇒ ('a × 'a) fset ⇒ ('a × 'a) fset" is ntrancl
  by (intro finite_ntrancl) simp

lift_definition frelcomp :: "('a × 'b) fset ⇒ ('b × 'c) fset ⇒ ('a × 'c) fset" (infixr "|O|" 75) is relcomp
  by (intro finite_relcomp) simp

lemmas frelcompE[elim!] = relcompE[Transfer.transferred]
lemmas frelcompI[intro] = relcompI[Transfer.transferred]
lemma fId_on_frelcomp_id:
  "fst |`| R |⊆| S ⟹ fId_on S |O| R = R"
  by (auto intro!: frelcompI)
lemma fId_on_frelcomp_id2:
 "snd |`| R |⊆| S ⟹ R |O| fId_on S = R"
  by (auto intro!: frelcompI)


lemmas fimage_fset = image_set[Transfer.transferred]
lemmas ftrancl_Un2_separatorE = trancl_Un2_separatorE[Transfer.transferred]

(* finite vars of term finite function symbols of terms *)

lemma finite_funs_term: "finite (funs_term t)" by (induct t) auto
lemma finite_funas_term: "finite (funas_term t)" by (induct t) auto
lemma finite_vars_ctxt: "finite (vars_ctxt C)" by (induct C) auto

lift_definition ffuns_term :: "('f, 'v) term ⇒ 'f fset" is funs_term using finite_funs_term
  by blast
lift_definition fvars_term :: "('f, 'v) term ⇒ 'v fset" is vars_term by simp
lift_definition fvars_ctxt :: "('f, 'v) ctxt ⇒ 'v fset" is vars_ctxt by (simp add: finite_vars_ctxt)


lemmas fvars_term_ctxt_apply [simp] = vars_term_ctxt_apply[Transfer.transferred]
lemmas fvars_term_of_gterm [simp] = vars_term_of_gterm[Transfer.transferred]
lemmas ground_fvars_term_empty [simp] = ground_vars_term_empty[Transfer.transferred]

lemma ffuns_term_Var [simp]: "ffuns_term (Var x) = {||}"
  by transfer auto
lemma fffuns_term_Fun [simp]: "ffuns_term (Fun f ts) = |⋃| (ffuns_term |`| fset_of_list ts) |∪| {|f|}"
  by transfer auto

lemma fvars_term_Var [simp]: "fvars_term (Var x) = {|x|}"
  by transfer auto
lemma fvars_term_Fun [simp]: "fvars_term (Fun f ts) = |⋃| (fvars_term |`| fset_of_list ts)"
  by transfer auto

lift_definition ffunas_term :: "('f, 'v) term ⇒ ('f × nat) fset" is funas_term
  by (simp add: finite_funas_term)
lift_definition ffunas_gterm :: "'f gterm ⇒ ('f × nat) fset" is funas_gterm
  by (simp add: finite_funas_gterm)

lemmas ffunas_term_simps [simp] = funas_term.simps[Transfer.transferred]
lemmas ffunas_gterm_simps [simp] = funas_gterm.simps[Transfer.transferred]
lemmas ffunas_term_of_gterm_conv = funas_term_of_gterm_conv[Transfer.transferred]
lemmas ffunas_gterm_gterm_of_term = funas_gterm_gterm_of_term[Transfer.transferred]


lemma sorted_list_of_fset_fimage_dist:
  "sorted_list_of_fset (f |`| A) = sort (remdups (map f (sorted_list_of_fset A)))"
  by (auto simp: sorted_list_of_fset.rep_eq simp flip: sorted_list_of_set_sort_remdups)

end

(* Move me *)
lemma finite_snd [intro]:
  "finite S ⟹ finite {x. (y, x) ∈ S}"
  by (induct S rule: finite.induct) auto

lemma finite_Collect_less_eq:
  "Q ≤ P ⟹ finite (Collect P) ⟹ finite (Collect Q)"
  by (metis (full_types) Ball_Collect infinite_iff_countable_subset rev_predicate1D)


datatype 'a FSet_Lex_Wrapper = Wrapp (ex: "'a fset")

lemma inj_FSet_Lex_Wrapper: "inj Wrapp"
  unfolding inj_def by auto

lemmas ftrancl_map_both = inj_on_trancl_map_both[Transfer.transferred]

instantiation FSet_Lex_Wrapper :: (linorder) linorder
begin

definition less_eq_FSet_Lex_Wrapper :: "('a :: linorder) FSet_Lex_Wrapper ⇒ 'a FSet_Lex_Wrapper ⇒ bool"
  where "less_eq_FSet_Lex_Wrapper S T =
    (let S' = sorted_list_of_fset (ex S) in
     let T' = sorted_list_of_fset (ex T) in
     S' ≤ T')"

definition less_FSet_Lex_Wrapper :: "'a FSet_Lex_Wrapper ⇒ 'a FSet_Lex_Wrapper ⇒ bool"
  where "less_FSet_Lex_Wrapper S T =
    (let S' = sorted_list_of_fset (ex S) in
     let T' = sorted_list_of_fset (ex T) in
     S' < T')"

instance by (intro_classes)
   (auto simp: less_eq_FSet_Lex_Wrapper_def less_FSet_Lex_Wrapper_def ex_def FSet_Lex_Wrapper.expand dest: sorted_list_of_fset_id)
end


end
y>

Theory Ground_Ctxt

theory Ground_Ctxt
  imports Ground_Terms
begin

subsubsection ‹Ground context›

datatype (gfuns_ctxt: 'f) gctxt =
  GHole ("□G") | GMore 'f "'f gterm list" "'f gctxt" "'f gterm list"
declare gctxt.map_comp[simp]

fun gctxt_apply_term :: "'f gctxt ⇒ 'f gterm ⇒ 'f gterm" ("_⟨_⟩G" [1000, 0] 1000) where
  "□G⟨s⟩G = s" |
  "(GMore f ss1 C ss2)⟨s⟩G = GFun f (ss1 @ C⟨s⟩G # ss2)"

fun hole_gpos where
  "hole_gpos □G = []" |
  "hole_gpos (GMore f ss1 C ss2) = length ss1 # hole_gpos C"

lemma gctxt_eq [simp]: "(C⟨s⟩G = C⟨t⟩G) = (s = t)"
  by (induct C) auto

fun gctxt_compose :: "'f gctxt ⇒ 'f gctxt ⇒ 'f gctxt" (infixl "∘Gc" 75) where
  "□G ∘Gc D = D" |
  "(GMore f ss1 C ss2) ∘Gc D = GMore f ss1 (C ∘Gc D) ss2"

fun gctxt_at_pos :: "'f gterm ⇒ pos ⇒ 'f gctxt" where
  "gctxt_at_pos t [] = □G" |
  "gctxt_at_pos (GFun f ts) (i # ps) =
    GMore f (take i ts) (gctxt_at_pos (ts ! i) ps) (drop (Suc i) ts)"

interpretation ctxt_monoid_mult: monoid_mult "□G" "(∘Gc)"
proof
  fix C D E :: "'f gctxt"
  show "C ∘Gc D ∘Gc E = C ∘Gc (D ∘Gc E)" by (induct C) simp_all
  show "□G ∘Gc C = C" by simp
  show "C ∘Gc □G = C" by (induct C) simp_all
qed

instantiation gctxt :: (type) monoid_mult
begin
  definition [simp]: "1 = □G"
  definition [simp]: "(*) = (∘Gc)"
  instance by (intro_classes) (simp_all add: ac_simps)
end

lemma ctxt_ctxt_compose [simp]: "(C ∘Gc D)⟨t⟩G = C⟨D⟨t⟩G⟩G"
  by (induct C) simp_all

lemmas ctxt_ctxt = ctxt_ctxt_compose [symmetric]

fun ctxt_of_gctxt where
   "ctxt_of_gctxt □G = □"
|  "ctxt_of_gctxt (GMore f ss C ts) = More f (map term_of_gterm ss) (ctxt_of_gctxt C) (map term_of_gterm ts)"

fun gctxt_of_ctxt where
   "gctxt_of_ctxt □ = □G"
|  "gctxt_of_ctxt (More f ss C ts) = GMore f (map gterm_of_term ss) (gctxt_of_ctxt C) (map gterm_of_term ts)"

lemma ground_ctxt_of_gctxt [simp]:
  "ground_ctxt (ctxt_of_gctxt s)"
  by (induct s) auto

lemma ground_ctxt_of_gctxt' [simp]:
  "ctxt_of_gctxt C = More f ss D ts ⟹ ground_ctxt (More f ss D ts)"
  by (induct C) auto

lemma ctxt_of_gctxt_inv [simp]:
  "gctxt_of_ctxt (ctxt_of_gctxt t) = t"
  by (induct t) (auto intro!: nth_equalityI)

lemma inj_ctxt_of_gctxt: "inj_on ctxt_of_gctxt X"
  by (metis inj_on_def ctxt_of_gctxt_inv)

lemma gctxt_of_ctxt_inv [simp]:
  "ground_ctxt C ⟹ ctxt_of_gctxt (gctxt_of_ctxt C) = C"
  by (induct C) (auto 0 0 intro!: nth_equalityI)

lemma map_ctxt_of_gctxt [simp]:
  "map_ctxt f g (ctxt_of_gctxt C) = ctxt_of_gctxt (map_gctxt f C)"
  by (induct C) auto

lemma map_gctxt_of_ctxt [simp]:
  "ground_ctxt C ⟹ gctxt_of_ctxt (map_ctxt f g C) = map_gctxt f (gctxt_of_ctxt C)"
  by (induct C) auto

lemma map_gctxt_nempty [simp]:
  "C ≠ □G ⟹ map_gctxt f C ≠ □G"
  by (cases C) auto

lemma gctxt_set_funs_ctxt:
  "gfuns_ctxt C = funs_ctxt (ctxt_of_gctxt C)"
  using gterm_set_gterm_funs_terms 
  by (induct C) fastforce+

lemma ctxt_set_funs_gctxt:
  assumes "ground_ctxt C"
  shows "gfuns_ctxt (gctxt_of_ctxt C) = funs_ctxt C"
  using assms term_set_gterm_funs_terms
  by (induct C) fastforce+

lemma vars_ctxt_of_gctxt [simp]:
  "vars_ctxt (ctxt_of_gctxt C) = {}"
  by (induct C) auto

lemma vars_ctxt_of_gctxt_subseteq [simp]:
  "vars_ctxt (ctxt_of_gctxt C) ⊆ Q ⟷ True"
  by auto

lemma term_of_gterm_ctxt_apply_ground [simp]:
  "term_of_gterm s = C⟨l⟩ ⟹ ground_ctxt C"
  "term_of_gterm s = C⟨l⟩ ⟹ ground l"
  by (metis ground_ctxt_apply ground_term_of_gterm)+

lemma term_of_gterm_ctxt_subst_apply_ground [simp]:
  "term_of_gterm s = C⟨l ⋅ σ⟩ ⟹ x ∈ vars_term l ⟹ ground (σ x)"
  by (meson ground_substD term_of_gterm_ctxt_apply_ground(2))

lemma gctxt_compose_HoleE:
 "C ∘Gc D = □G ⟹ C = □G"
 "C ∘Gc D = □G ⟹ D = □G"
  by (cases C; cases D, auto)+


― ‹Relations between ground contexts and contexts›

lemma nempty_ground_ctxt_gctxt [simp]:
  "C ≠ □ ⟹ ground_ctxt C ⟹ gctxt_of_ctxt C ≠ □G"
  by (induct C) auto

lemma ctxt_of_gctxt_apply [simp]:
  "gterm_of_term (ctxt_of_gctxt C)⟨term_of_gterm t⟩ = C⟨t⟩G"
  by (induct C) (auto simp: comp_def map_idI)

lemma ctxt_of_gctxt_apply_gterm:
  "gterm_of_term (ctxt_of_gctxt C)⟨t⟩ = C⟨gterm_of_term t⟩G"
  by (induct C) (auto simp: comp_def map_idI)

lemma ground_gctxt_of_ctxt_apply_gterm:
  assumes "ground_ctxt C"
  shows "term_of_gterm (gctxt_of_ctxt C)⟨t⟩G = C⟨term_of_gterm t⟩" using assms
  by (induct C) (auto simp: comp_def map_idI)

lemma ground_gctxt_of_ctxt_apply [simp]:
  assumes "ground_ctxt C" "ground t"  
  shows "term_of_gterm (gctxt_of_ctxt C)⟨gterm_of_term t⟩G = C⟨t⟩" using assms
  by (induct C) (auto simp: comp_def map_idI)

lemma term_of_gterm_ctxt_apply [simp]:
  "term_of_gterm s = C⟨l⟩ ⟹ (gctxt_of_ctxt C)⟨gterm_of_term l⟩G = s"
  by (metis ctxt_of_gctxt_apply_gterm gctxt_of_ctxt_inv term_of_gterm_ctxt_apply_ground(1) term_of_gterm_inv)

lemma gctxt_apply_inj_term: "inj (gctxt_apply_term C)"
  by (auto simp: inj_on_def)

lemma gctxt_apply_inj_on_term: "inj_on (gctxt_apply_term C) S"
  by (auto simp: inj_on_def)

lemma ctxt_of_pos_gterm [simp]:
  "p ∈ gposs t ⟹ ctxt_at_pos (term_of_gterm t) p = ctxt_of_gctxt (gctxt_at_pos t p)"
  by (induct t arbitrary: p) (auto simp add: take_map drop_map)

lemma gctxt_of_gpos_gterm_gsubt_at_to_gterm [simp]:
  assumes "p ∈ gposs t"
  shows "(gctxt_at_pos t p)⟨gsubt_at t p⟩G = t" using assms
  by (induct t arbitrary: p) (auto simp: comp_def min_def nth_append_Cons intro!: nth_equalityI)  

text ‹The position of the hole in a context is uniquely determined›
fun ghole_pos :: "'f gctxt ⇒ pos" where
  "ghole_pos □G = []" |
  "ghole_pos (GMore f ss D ts) = length ss # ghole_pos D"

lemma ghole_pos_gctxt_at_pos [simp]:
  "p ∈ gposs t ⟹ ghole_pos (gctxt_at_pos t p) = p"
  by (induct t arbitrary: p) auto

lemma ghole_pos_id_ctxt [simp]:
  "C⟨s⟩G = t ⟹ gctxt_at_pos t (ghole_pos C) = C"
  by (induct C arbitrary: t) auto

lemma ghole_pos_in_apply:
  "ghole_pos C = p ⟹ p ∈ gposs C⟨u⟩G"
  by (induct C arbitrary: p) (auto simp: nth_append)

lemma ground_hole_pos_to_ghole:
  "ground_ctxt C ⟹ ghole_pos (gctxt_of_ctxt C) = hole_pos C"
  by (induct C) auto

lemma gsubst_at_gctxt_at_eq_gtermD:
  assumes "s = t" "p ∈ gposs t"
  shows "gsubt_at s p = gsubt_at t p ∧ gctxt_at_pos s p = gctxt_at_pos t p" using assms
  by auto

lemma gsubst_at_gctxt_at_eq_gtermI:
  assumes "p ∈ gposs s" "p ∈ gposs t"
    and "gsubt_at s p = gsubt_at t p"
    and "gctxt_at_pos s p = gctxt_at_pos t p"
  shows "s = t" using assms
  using gctxt_of_gpos_gterm_gsubt_at_to_gterm by force


lemma gsubt_at_gctxt_apply_ghole [simp]:
  "gsubt_at C⟨u⟩G (ghole_pos C) = u"
  by (induct C) auto

lemma gctxt_at_pos_gsubt_at_pos [simp]:
  "p ∈ gposs t ⟹ gsubt_at (gctxt_at_pos t p)⟨u⟩G p = u"
proof (induct p arbitrary: t)
  case (Cons i p)
  then show ?case using id_take_nth_drop
    by (cases t) (auto simp: nth_append)
qed auto

lemma gfun_at_gctxt_at_pos_not_after:
  assumes "p ∈ gposs t" "q ∈ gposs t" "¬ (p ≤p q)"
  shows "gfun_at (gctxt_at_pos t p)⟨v⟩G q = gfun_at t q" using assms
proof (induct q arbitrary: p t)
  case Nil
  then show ?case
    by (cases p; cases t) auto
next
  case (Cons i q)
  from Cons(4) obtain j r where [simp]: "p = j # r" by (cases p) auto
  from Cons(4) have "j = i ⟹ ¬ (r ≤p q)" by auto
  from this Cons(2-) Cons(1)[of r "gargs t ! j"]
  have "j = i ⟹ gfun_at (gctxt_at_pos (gargs t ! j) r)⟨v⟩G q = gfun_at (gargs t ! j) q"
    by (cases t) auto
  then show ?case using Cons(2, 3)
    by (cases t) (auto simp: nth_append_Cons min_def)
qed

lemma gpos_less_eq_append [simp]: "p ≤p (p @ q)"
  unfolding position_less_eq_def
  by blast

lemma gposs_ConsE [elim]:
  assumes "i # p ∈ gposs t"
  obtains f ts where "t = GFun f ts" "ts ≠ []" "i < length ts" "p ∈ gposs (ts ! i)" using assms
  by (cases t) force+

lemma gposs_gctxt_at_pos_not_after:
  assumes "p ∈ gposs t" "q ∈ gposs t" "¬ (p ≤p q)"
  shows "q ∈ gposs (gctxt_at_pos t p)⟨v⟩G ⟷ q ∈ gposs t" using assms
proof (induct q arbitrary: p t)
  case Nil then show ?case
    by (cases p; cases t) auto
next
  case (Cons i q)
  from Cons(4) obtain j r where [simp]: "p = j # r" by (cases p) auto
  from Cons(4) have "j = i ⟹ ¬ (r ≤p q)" by auto
  from this Cons(2-) Cons(1)[of r "gargs t ! j"]
  have "j = i ⟹ q ∈ gposs (gctxt_at_pos (gargs t ! j) r)⟨v⟩G ⟷ q ∈ gposs (gargs t ! j)"
    by (cases t) auto
  then show ?case using Cons(2, 3)
    by (cases t) (auto simp: nth_append_Cons min_def)
qed

lemma gposs_gctxt_at_pos:
  "p ∈ gposs t ⟹ gposs (gctxt_at_pos t p)⟨v⟩G = {q. q ∈ gposs t ∧ ¬ (p ≤p q)} ∪ (@) p ` gposs v"
proof (induct p arbitrary: t)
  case (Cons i p)
  show ?case using Cons(1)[of "gargs t ! i"] Cons(2) gposs_gctxt_at_pos_not_after[OF Cons(2)]
    by (auto simp: min_def nth_append_Cons split: if_splits elim!: gposs_ConsE)
qed auto

lemma eq_gctxt_at_pos:
  assumes "p ∈ gposs s" "p ∈ gposs t"
    and "⋀ q. ¬ (p ≤p q) ⟹ q ∈ gposs s ⟷ q ∈ gposs t"
    and "(⋀ q. q ∈ gposs s ⟹ ¬ (p ≤p q) ⟹ gfun_at s q = gfun_at t q)"
  shows "gctxt_at_pos s p = gctxt_at_pos t p" using assms(1, 2)
  using arg_cong[where ?f = gctxt_of_ctxt, OF eq_ctxt_at_pos_by_poss, of _ "term_of_gterm s :: (_, unit) term"
   "term_of_gterm t :: (_, unit) term" for s t, unfolded poss_gposs_conv fun_at_gfun_at_conv ctxt_of_pos_gterm,
   OF assms]
  by simp

text ‹Signature of a ground context›

fun funas_gctxt :: "'f gctxt ⇒ ('f × nat) set" where
  "funas_gctxt GHole = {}" |
  "funas_gctxt (GMore f ss1 D ss2) = {(f, Suc (length (ss1 @ ss2)))}
     ∪ funas_gctxt D ∪ ⋃(set (map funas_gterm (ss1 @ ss2)))"

lemma funas_gctxt_of_ctxt [simp]:
  "ground_ctxt C ⟹ funas_gctxt (gctxt_of_ctxt C) = funas_ctxt C"
  by (induct C) (auto simp: funas_gterm_gterm_of_term)

lemma funas_ctxt_of_gctxt_conv [simp]:
  "funas_ctxt (ctxt_of_gctxt C) = funas_gctxt C"
  by (induct C) (auto simp flip: funas_gterm_gterm_of_term)

lemma inj_gctxt_of_ctxt_on_ground:
  "inj_on gctxt_of_ctxt (Collect ground_ctxt)"
  using gctxt_of_ctxt_inv by (fastforce simp: inj_on_def)

lemma funas_gterm_ctxt_apply [simp]:
  "funas_gterm C⟨s⟩G = funas_gctxt C ∪ funas_gterm s"
  by (induct C) auto

lemma funas_gctxt_compose [simp]:
  "funas_gctxt (C ∘Gc D) = funas_gctxt C ∪ funas_gctxt D"
  by (induct C arbitrary: D) auto

end
body>

Theory Ground_Closure

theory Ground_Closure
  imports Ground_Terms
begin

subsubsection ‹Multihole context closure›

text ‹Computing the multihole context closure of a given relation›
inductive_set gmctxt_cl :: "('f × nat) set ⇒ 'f gterm rel ⇒ 'f gterm rel" for ℱ ℛ where
  base [intro]: "(s, t) ∈ ℛ ⟹ (s, t) ∈ gmctxt_cl ℱ ℛ"
| step [intro]: "length ss = length ts ⟹ (∀ i < length ts. (ss ! i, ts ! i) ∈ gmctxt_cl ℱ ℛ) ⟹ (f, length ss) ∈ ℱ ⟹
    (GFun f ss, GFun f ts) ∈ gmctxt_cl ℱ ℛ"

lemma gmctxt_cl_idemp [simp]:
  "gmctxt_cl ℱ (gmctxt_cl ℱ ℛ) = gmctxt_cl ℱ ℛ"
proof -
  {fix s t assume "(s, t) ∈ gmctxt_cl ℱ (gmctxt_cl ℱ ℛ)"
    then have "(s, t) ∈ gmctxt_cl ℱ ℛ"
      by (induct) (auto intro: gmctxt_cl.step)}
  then show ?thesis by auto
qed

lemma gmctxt_cl_refl:
  "funas_gterm t ⊆ ℱ ⟹ (t, t) ∈ gmctxt_cl ℱ ℛ"
  by (induct t) (auto simp: SUP_le_iff intro!: gmctxt_cl.step)

lemma gmctxt_cl_swap:
  "gmctxt_cl ℱ (prod.swap ` ℛ) = prod.swap ` gmctxt_cl ℱ ℛ" (is "?Ls = ?Rs")
proof -
  {fix s t assume "(s, t) ∈ ?Ls" then have "(s, t) ∈ ?Rs"
      by induct auto}
  moreover
  {fix s t assume "(s, t) ∈ ?Rs"
    then have "(t, s) ∈ gmctxt_cl ℱ ℛ" by auto
    then have "(s, t) ∈ ?Ls" by induct auto}
  ultimately show ?thesis by auto
qed

lemma gmctxt_cl_mono_funas:
  assumes "ℱ ⊆ 𝒢" shows "gmctxt_cl ℱ ℛ ⊆ gmctxt_cl 𝒢 ℛ"
proof -
  {fix s t assume "(s, t) ∈ gmctxt_cl ℱ ℛ" then have "(s, t) ∈ gmctxt_cl 𝒢 ℛ"
      by induct (auto simp: subsetD[OF assms])}
  then show ?thesis by auto
qed

lemma gmctxt_cl_mono_rel:
  assumes "𝒫 ⊆ ℛ" shows "gmctxt_cl ℱ 𝒫 ⊆ gmctxt_cl ℱ ℛ"
proof -
  {fix s t assume "(s, t) ∈ gmctxt_cl ℱ 𝒫" then have "(s, t) ∈ gmctxt_cl ℱ ℛ" using assms
      by induct auto}
  then show ?thesis by auto
qed

definition gcomp_rel :: "('f × nat) set ⇒ 'f gterm rel ⇒ 'f gterm rel ⇒ 'f gterm rel" where
  "gcomp_rel ℱ R S = (R O gmctxt_cl ℱ S) ∪ (gmctxt_cl ℱ R O S)"

definition gtrancl_rel :: "('f × nat) set ⇒ 'f gterm rel ⇒ 'f gterm rel" where
  "gtrancl_rel ℱ ℛ = (gmctxt_cl ℱ ℛ)+ O ℛ O (gmctxt_cl ℱ ℛ)+"

lemma gcomp_rel:
  "gmctxt_cl ℱ (gcomp_rel ℱ ℛ 𝒮) = gmctxt_cl ℱ ℛ O gmctxt_cl ℱ 𝒮" (is "?Ls = ?Rs")
proof
  { fix s u assume "(s, u) ∈ gmctxt_cl ℱ (ℛ O gmctxt_cl ℱ 𝒮 ∪ gmctxt_cl ℱ ℛ O 𝒮)"
     then have "∃t. (s, t) ∈ gmctxt_cl ℱ ℛ ∧ (t, u) ∈ gmctxt_cl ℱ 𝒮"
    proof (induct)
      case (step ss ts f)
      from Ex_list_of_length_P[of _ "λ u i. (ss ! i, u) ∈ gmctxt_cl ℱ ℛ ∧ (u, ts ! i) ∈ gmctxt_cl ℱ 𝒮"]
      obtain us where l: "length us = length ts" and
        inv: "∀ i < length ts. (ss ! i, us ! i) ∈ gmctxt_cl ℱ ℛ ∧ (us ! i, ts ! i) ∈ gmctxt_cl ℱ 𝒮"
        using step(2, 3) by blast
      then show ?case using step(1, 3)
        by (intro exI[of _ "GFun f us"]) auto
    qed auto}
  then show "?Ls ⊆ ?Rs" unfolding gcomp_rel_def
    by auto
next
  {fix s t u assume "(s, t) ∈ gmctxt_cl ℱ ℛ" "(t, u) ∈ gmctxt_cl ℱ 𝒮"
    then have "(s, u) ∈ gmctxt_cl ℱ (ℛ O gmctxt_cl ℱ 𝒮 ∪ gmctxt_cl ℱ ℛ O 𝒮)"
    proof (induct arbitrary: u rule: gmctxt_cl.induct)
      case (step ss ts f)
      then show ?case
      proof (cases "(GFun f ts, u) ∈ 𝒮")
        case True
        then have "(GFun f ss, u) ∈ gmctxt_cl ℱ ℛ O 𝒮" using gmctxt_cl.step[OF step(1) _ step(3)] step(2)
          by auto
        then show ?thesis by auto
      next
        case False
        then obtain us where u[simp]: "u = GFun f us" and l: "length ts = length us"
          using step(4) by (cases u) (auto elim: gmctxt_cl.cases)
        have "i < length us ⟹
         (ss ! i, us ! i) ∈ gmctxt_cl ℱ (ℛ O gmctxt_cl ℱ 𝒮 ∪ gmctxt_cl ℱ ℛ O 𝒮)" for i
          using step(1, 2, 4) False by (auto elim: gmctxt_cl.cases)
        then show ?thesis using l step(1, 3)
          by auto
      qed
    qed auto}
  then show "?Rs ⊆ ?Ls"
    by (auto simp: gcomp_rel_def)
qed

subsubsection ‹Signature closed property›

definition all_ctxt_closed :: "('f × nat) set ⇒ 'f gterm rel ⇒ bool" where
  "all_ctxt_closed F r ⟷ (∀ f ts ss. (f, length ss) ∈ F ⟶ length ss = length ts ⟶
    (∀i. i < length ts ⟶ (ss ! i, ts ! i) ∈ r) ⟶
    (GFun f ss, GFun f ts) ∈ r)"

lemma all_ctxt_closedI:
  assumes "⋀ f ss ts. (f, length ss) ∈ ℱ ⟹ length ss = length ts ⟹
     (∀ i < length ts. (ss ! i, ts ! i) ∈ r) ⟹ (GFun f ss, GFun f ts) ∈ r"
  shows "all_ctxt_closed ℱ r" using assms
  unfolding all_ctxt_closed_def by auto

lemma all_ctxt_closedD:
  "all_ctxt_closed F r ⟹ (f, length ss) ∈ F ⟹ length ss = length ts ⟹
    (∀ i < length ts. (ss ! i, ts ! i) ∈ r) ⟹ (GFun f ss, GFun f ts) ∈ r"
  by (auto simp: all_ctxt_closed_def)

lemma all_ctxt_closed_refl_on:
  assumes "all_ctxt_closed ℱ r" "s ∈ 𝒯G ℱ"
  shows "(s, s) ∈ r" using assms(2)
  by (induct) (auto simp: all_ctxt_closedD[OF assms(1)])

lemma gmctxt_cl_is_all_ctxt_closed [simp]:
  "all_ctxt_closed ℱ (gmctxt_cl ℱ ℛ)"
  unfolding all_ctxt_closed_def
  by auto

lemma all_ctxt_closed_gmctxt_cl_idem [simp]:
  assumes "all_ctxt_closed ℱ ℛ"
  shows "gmctxt_cl ℱ ℛ = ℛ"
proof -
  {fix s t assume "(s, t) ∈ gmctxt_cl ℱ ℛ" then have "(s, t) ∈ ℛ"
    proof (induct)
      case (step ss ts f)
      show ?case using step(2) all_ctxt_closedD[OF assms step(3, 1)]
        by auto
    qed auto}
  then show ?thesis by auto
qed


subsubsection ‹Transitive closure preserves @{const all_ctxt_closed}›

text ‹induction scheme for transitive closures of lists›

inductive_set trancl_list for ℛ where
  base[intro, Pure.intro] : "length xs = length ys ⟹
      (∀ i < length ys. (xs ! i, ys ! i) ∈ ℛ) ⟹ (xs, ys) ∈ trancl_list ℛ"
| list_trancl [Pure.intro]: "(xs, ys) ∈ trancl_list ℛ ⟹ i < length ys ⟹ (ys ! i, z) ∈ ℛ ⟹
    (xs, ys[i := z]) ∈ trancl_list ℛ"

lemma trancl_list_appendI [simp, intro]:
  "(xs, ys) ∈ trancl_list ℛ ⟹ (x, y) ∈ ℛ ⟹ (x # xs, y # ys) ∈ trancl_list ℛ"
proof (induct rule: trancl_list.induct)
  case (base xs ys)
  then show ?case using less_Suc_eq_0_disj
    by (intro trancl_list.base) auto
next
  case (list_trancl xs ys i z)
  from list_trancl(3) have *: "y # ys[i := z] = (y # ys)[Suc i := z]" by auto
  show ?case using list_trancl unfolding *
    by (intro trancl_list.list_trancl) auto
qed

lemma trancl_list_append_tranclI [intro]:
  "(x, y) ∈ ℛ+ ⟹ (xs, ys) ∈ trancl_list ℛ ⟹ (x # xs, y # ys) ∈ trancl_list ℛ"
proof (induct rule: trancl.induct)
  case (trancl_into_trancl a b c)
  then have "(a # xs, b # ys) ∈ trancl_list ℛ" by auto
  from trancl_list.list_trancl[OF this, of 0 c]
  show ?case using trancl_into_trancl(3)
    by auto
qed auto

lemma trancl_list_conv:
  "(xs, ys) ∈ trancl_list ℛ ⟷ length xs = length ys ∧ (∀ i < length ys. (xs ! i, ys ! i) ∈ ℛ+)" (is "?Ls ⟷ ?Rs")
proof
  assume "?Ls" then show ?Rs
  proof (induct)
    case (list_trancl xs ys i z)
    then show ?case
      by auto (metis nth_list_update trancl.trancl_into_trancl)
  qed auto
next
  assume ?Rs then show ?Ls
  proof (induct ys arbitrary: xs)
    case Nil
    then show ?case by (cases xs) auto
  next
    case (Cons y ys)
    from Cons(2) obtain x xs' where *: "xs = x # xs'" and
      inv: "(x, y) ∈ ℛ+"
      by (cases xs) auto
    show ?case using Cons(1)[of "tl xs"] Cons(2) unfolding *
      by (intro trancl_list_append_tranclI[OF inv]) force
  qed
qed

lemma trancl_list_induct [consumes 2, case_names base step]:
  assumes "length ss = length ts" "∀ i < length ts. (ss ! i, ts ! i) ∈ ℛ+"
    and "⋀xs ys. length xs = length ys ⟹ ∀ i < length ys. (xs ! i, ys ! i) ∈ ℛ ⟹ P xs ys"
    and "⋀xs ys i z. length xs = length ys ⟹ ∀ i < length ys. (xs ! i, ys ! i) ∈ ℛ+ ⟹ P xs ys
      ⟹ i < length ys ⟹ (ys ! i, z) ∈ ℛ ⟹ P xs (ys[i := z])"
  shows "P ss ts" using assms
  by (intro trancl_list.induct[of ss ts ℛ P]) (auto simp: trancl_list_conv)

lemma trancl_list_all_step_induct [consumes 2, case_names base step]:
  assumes "length ss = length ts" "∀ i < length ts. (ss ! i, ts ! i) ∈ ℛ+"
    and base: "⋀xs ys. length xs = length ys ⟹ ∀ i < length ys. (xs ! i, ys ! i) ∈ ℛ ⟹ P xs ys"
    and steps: "⋀xs ys zs. length xs = length ys ⟹ length ys = length zs ⟹
       ∀ i < length zs. (xs ! i, ys ! i) ∈ ℛ+ ⟹ ∀ i < length zs. (ys ! i, zs ! i) ∈ ℛ ∨ ys ! i = zs ! i ⟹
       P xs ys ⟹ P xs zs"
  shows "P ss ts" using assms(1, 2)
proof (induct rule: trancl_list_induct)
case (step xs ys i z)
  then show ?case
    by (intro steps[of xs ys "ys[i := z]"])
       (auto simp: nth_list_update)
qed (auto simp: base)

lemma all_ctxt_closed_trancl:
  assumes  "all_ctxt_closed ℱ ℛ" "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "all_ctxt_closed ℱ (ℛ+)"
proof -
  {fix f ss ts assume sig: "(f, length ss) ∈ ℱ" and
      steps: "length ss = length ts" "∀i<length ts. (ss ! i, ts ! i) ∈ ℛ+"
    have "(GFun f ss, GFun f ts) ∈ ℛ+" using steps sig
    proof (induct rule: trancl_list_induct)
      case (base ss ts)
      then show ?case using all_ctxt_closedD[OF assms(1) base(3, 1, 2)]
        by auto
    next
      case (step ss ts i t')
      from step(2) have "j < length ts ⟹ ts ! j ∈ 𝒯G ℱ" for j using assms(2)
        by (metis (no_types, lifting) SigmaD2 subset_iff trancl.simps)
      from this[THEN all_ctxt_closed_refl_on[OF assms(1)]]
      have "(GFun f ts, GFun f (ts[i := t'])) ∈ ℛ" using step(1, 4-)
        by (intro all_ctxt_closedD[OF assms(1)]) (auto simp: nth_list_update)
      then show ?case using step(3, 6)
        by auto
    qed}
  then show ?thesis by (intro all_ctxt_closedI)
qed

end
body>

Theory Horn_Inference

theory Horn_Inference
  imports Main
begin

datatype 'a horn = horn "'a list" 'a (infix "→h" 55)

locale horn =
  fixes ℋ :: "'a horn set"
begin

inductive_set saturate :: "'a set" where
  infer: "as →h a ∈ ℋ ⟹ (⋀x. x ∈ set as ⟹ x ∈ saturate) ⟹ a ∈ saturate"

definition infer0 where
  "infer0 = {a. [] →h a ∈ ℋ}"

definition infer1 where
  "infer1 x B = {a |as a. as →h a ∈ ℋ ∧ x ∈ set as ∧ set as ⊆ B ∪ {x}}"

inductive step :: "'a set × 'a set ⇒ 'a set × 'a set ⇒ bool" (infix "⊢" 50) where
  delete: "x ∈ B ⟹ (insert x G, B) ⊢ (G, B)"
| propagate: "(insert x G, B) ⊢ (G ∪ infer1 x B, insert x B)"
| refl: "(G, B) ⊢ (G, B)"
| trans: "(G, B) ⊢ (G', B') ⟹ (G', B') ⊢ (G'', B'') ⟹ (G, B) ⊢ (G'', B'')"

lemma step_mono:
  "(G, B) ⊢ (G', B') ⟹ (H ∪ G, B) ⊢ (H ∪ G', B')"
  by (induction "(G, B)" "(G', B')" arbitrary: G B G' B' rule: step.induct)
    (auto intro: step.intros simp: Un_assoc[symmetric])

fun invariant where
  "invariant (G, B) ⟷ G ⊆ saturate ∧ B ⊆ saturate ∧ (∀a as. as →h a ∈ ℋ ∧ set as ⊆ B ⟶ a ∈ G ∪ B)"

lemma inv_start:
  shows "invariant (infer0, {})"
  by (auto simp: infer0_def invariant.simps intro: infer)

lemma inv_step:
  assumes "invariant (G, B)" "(G, B) ⊢ (G', B')"
  shows "invariant (G', B')"
  using assms(2,1)
proof (induction "(G, B)" "(G', B')" arbitrary: G B G' B' rule: step.induct)
  case (propagate x G B)
  let ?G' = "G ∪ local.infer1 x B" and ?B' = "insert x B"
  have "?G' ⊆ saturate" "?B' ⊆ saturate"
    using assms(1) propagate by (auto 0 3 simp: infer1_def intro: saturate.infer)
  moreover have "as →h a ∈ ℋ ⟹ set as ⊆ ?B' ⟹ a ∈ ?G' ∪ ?B'" for a as
    using assms(1) propagate by (fastforce simp: infer1_def)
  ultimately show ?case by auto
qed auto

lemma inv_end:
  assumes "invariant ({}, B)"
  shows "B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) then show ?case using assms by auto
next
  case (rl x) then show ?case using assms
    by (induct x rule: saturate.induct) fastforce
qed

lemma step_sound:
  "(infer0, {}) ⊢ ({}, B) ⟹ B = saturate"
  by (metis inv_start inv_step inv_end)

end

lemma horn_infer0_union:
  "horn.infer0 (ℋ1 ∪ ℋ2) = horn.infer0 ℋ1 ∪ horn.infer0 ℋ2"
  by (auto simp: horn.infer0_def)

lemma horn_infer1_union:
  "horn.infer1 (ℋ1 ∪ ℋ2) x B = horn.infer1 ℋ1 x B ∪ horn.infer1 ℋ2 x B"
  by (auto simp: horn.infer1_def)

end

Theory Horn_List

theory Horn_List
  imports Horn_Inference
begin

locale horn_list_impl = horn +
  fixes infer0_impl :: "'a list" and infer1_impl :: "'a ⇒ 'a list ⇒ 'a list"
begin

lemma saturate_fold_simp [simp]:
  "fold (λxa. case_option None (f xa)) xs None = None"
  by (induct xs) auto

lemma saturate_fold_mono [partial_function_mono]:
  "option.mono_body (λf. fold (λx. case_option None (λy. f (x, y))) xs b)"
  unfolding monotone_def fun_ord_def flat_ord_def
proof (intro allI impI, induct xs arbitrary: b)
  case (Cons a xs)
  show ?case
    using Cons(1)[OF Cons(2), of "x (a, the b)"] Cons(2)[rule_format, of "(a, the b)"]
    by (cases b) auto
qed auto

partial_function (option) saturate_rec :: "'a ⇒ 'a list ⇒ ('a list) option" where
  "saturate_rec x bs = (if x ∈ set bs then Some bs else
     fold (λx. case_option None (saturate_rec x)) (infer1_impl x bs) (Some (x # bs)))"

definition saturate_impl where
  "saturate_impl = fold (λx. case_option None (saturate_rec x)) infer0_impl (Some [])"

end

locale horn_list = horn_list_impl +
  assumes infer0: "infer0 = set infer0_impl"
    and infer1: "⋀x bs. infer1 x (set bs) = set (infer1_impl x bs)"
begin

lemma saturate_rec_sound:
  "saturate_rec x bs = Some bs' ⟹ ({x}, set bs) ⊢ ({}, set bs')"
proof (induct arbitrary: x bs bs' rule: saturate_rec.fixp_induct)
  case 1 show ?case using option_admissible[of "λ(x, y) z. _ x y z"]
    by fastforce
next
  case (3 rec)
  have [dest!]: "(set xs, set ys) ⊢ ({}, set bs')"
    if "fold (λx a. case a of None ⇒ None | Some a ⇒ rec x a) xs (Some ys) = Some bs'"
    for xs ys using that
  proof (induct xs arbitrary: ys)
    case (Cons a xs)
    show ?case using trans[OF step_mono[OF 3(1)], of a ys _ "set xs" "{}" "set bs'"] Cons
      by (cases "rec a ys") auto
  qed (auto intro: refl)
  show ?case using propagate[of x "{}" "set bs", unfolded infer1 Un_empty_left] 3(2)
    by (auto split: if_splits intro: trans delete)
qed auto

lemma saturate_impl_sound:
  assumes "saturate_impl = Some B'"
  shows "set B' = saturate"
proof -
  have "(set xs, set ys) ⊢ ({}, set bs')"
    if "fold (λx a. case a of None ⇒ None | Some a ⇒ saturate_rec x a) xs (Some ys) = Some bs'"
    for xs ys bs' using that
  proof (induct xs arbitrary: ys)
    case (Cons a xs)
    show ?case
      using trans[OF step_mono[OF saturate_rec_sound], of a ys _ "set xs" "{}" "set bs'"] Cons
      by (cases "saturate_rec a ys") auto
  qed (auto intro: refl)
  from this[of infer0_impl "[]" B'] assms step_sound show ?thesis
    by (auto simp: saturate_impl_def infer0)
qed

lemma saturate_impl_complete:
  assumes "finite saturate"
  shows "saturate_impl ≠ None"
proof -
  have *: "fold (λx. case_option None (saturate_rec x)) ds (Some bs) ≠ None"
    if "set bs ⊆ saturate" "set ds ⊆ saturate" for bs ds
    using that
  proof (induct "card (saturate - set bs)" arbitrary: bs ds rule: less_induct)
    case less
    show ?case using less(3)
    proof (induct ds)
      case (Cons d ds)
      have "infer1 d (set bs) ⊆ saturate" using less(2) Cons(2)
        unfolding infer1_def by (auto intro: saturate.infer)
      moreover have "card (saturate - set (d # bs)) < card (saturate - set bs)" if "d ∉ set bs"
        using Cons(2) assms that
        by (metis (no_types, lifting) DiffI card_Diff1_less_iff card_Diff_insert card_Diff_singleton_if finite_Diff list.set_intros(1) list.simps(15) subsetD)
      ultimately show ?case using less(1)[of "d # bs" "infer1_impl d bs @ ds"] less(2) Cons assms
        unfolding fold.simps comp_def option.simps
        by (subst saturate_rec.simps) (auto split: if_splits simp: infer1)
    qed simp
  qed
  show ?thesis using *[of "[]" "infer0_impl"] inv_start by (simp add: saturate_impl_def infer0)
qed

end

lemmas [code] = horn_list_impl.saturate_rec.simps horn_list_impl.saturate_impl_def

end

Theory Horn_Fset

theory Horn_Fset
  imports Horn_Inference FSet_Utils
begin

locale horn_fset_impl = horn +
  fixes infer0_impl :: "'a list" and infer1_impl :: "'a ⇒ 'a fset ⇒ 'a list"
begin

lemma saturate_fold_simp [simp]:
  "fold (λxa. case_option None (f xa)) xs None = None"
  by (induct xs) auto

lemma saturate_fold_mono [partial_function_mono]:
  "option.mono_body (λf. fold (λx. case_option None (λy. f (x, y))) xs b)"
  unfolding monotone_def fun_ord_def flat_ord_def
proof (intro allI impI, induct xs arbitrary: b)
  case (Cons a xs)
  show ?case
    using Cons(1)[OF Cons(2), of "x (a, the b)"] Cons(2)[rule_format, of "(a, the b)"]
    by (cases b) auto
qed auto

partial_function (option) saturate_rec :: "'a ⇒ 'a fset ⇒ ('a fset) option" where
  "saturate_rec x bs = (if x |∈| bs then Some bs else
     fold (λx. case_option None (saturate_rec x)) (infer1_impl x bs) (Some (finsert x bs)))"

definition saturate_impl where
  "saturate_impl = fold (λx. case_option None (saturate_rec x)) infer0_impl (Some {||})"

end

locale horn_fset = horn_fset_impl +
  assumes infer0: "infer0 = set infer0_impl"
    and infer1: "⋀x bs. infer1 x (fset bs) = set (infer1_impl x bs)"
begin

lemma saturate_rec_sound:
  "saturate_rec x bs = Some bs' ⟹ ({x}, fset bs) ⊢ ({}, fset bs')"
proof (induct arbitrary: x bs bs' rule: saturate_rec.fixp_induct)
  case 1 show ?case using option_admissible[of "λ(x, y) z. _ x y z"]
    by fastforce
next
  case (3 rec)
  have [dest!]: "(set xs, fset ys) ⊢ ({}, fset bs')"
    if "fold (λx a. case a of None ⇒ None | Some a ⇒ rec x a) xs (Some ys) = Some bs'"
    for xs ys using that
  proof (induct xs arbitrary: ys)
    case (Cons a xs)
    show ?case using trans[OF step_mono[OF 3(1)], of a ys _ "set xs" "{}" "fset bs'"] Cons
      by (cases "rec a ys") auto
  qed (auto intro: refl)
  show ?case using propagate[of x "{}" "fset bs", unfolded infer1 Un_empty_left] 3(2)
    by (auto simp: delete fmember.rep_eq split: if_splits intro: trans delete)
qed auto

lemma saturate_impl_sound:
  assumes "saturate_impl = Some B'"
  shows "fset B' = saturate"
proof -
  have "(set xs, fset ys) ⊢ ({}, fset bs')"
    if "fold (λx a. case a of None ⇒ None | Some a ⇒ saturate_rec x a) xs (Some ys) = Some bs'"
    for xs ys bs' using that
  proof (induct xs arbitrary: ys)
    case (Cons a xs)
    show ?case
      using trans[OF step_mono[OF saturate_rec_sound], of a ys _ "set xs" "{}" "fset bs'"] Cons
      by (cases "saturate_rec a ys") auto
  qed (auto intro: refl)
  from this[of infer0_impl "{||}" B'] assms step_sound show ?thesis
    by (auto simp: saturate_impl_def infer0)
qed

lemma saturate_impl_complete:
  assumes "finite saturate"
  shows "saturate_impl ≠ None"
proof -
  have *: "fold (λx. case_option None (saturate_rec x)) ds (Some bs) ≠ None"
    if "fset bs ⊆ saturate" "set ds ⊆ saturate" for bs ds
    using that
  proof (induct "card (saturate - fset bs)" arbitrary: bs ds rule: less_induct)
    case less
    show ?case using less(3)
    proof (induct ds)
      case (Cons d ds)
      have "infer1 d (fset bs) ⊆ saturate" using less(2) Cons(2)
        unfolding infer1_def by (auto intro: saturate.infer)
      moreover have "card (saturate - fset (finsert d bs)) < card (saturate - fset bs)" if "d ∉ fset bs"
        using Cons(2) assms that
        by (metis DiffI Diff_insert card_Diff1_less finite_Diff finsert.rep_eq in_mono insertCI list.simps(15))
      ultimately show ?case using less(1)[of "finsert d bs" "infer1_impl d bs @ ds"] less(2) Cons assms
        unfolding fold.simps comp_def option.simps
        apply (subst saturate_rec.simps)
        apply (auto simp flip: saturate_rec.simps split!: if_splits simp: infer1)
        apply (simp add: notin_fset saturate_rec.simps)
        done
    qed simp
  qed
  show ?thesis using *[of "{||}" "infer0_impl"] inv_start by (simp add: saturate_impl_def infer0)
qed

end

lemmas [code] = horn_fset_impl.saturate_rec.simps horn_fset_impl.saturate_impl_def

end
ody>

Theory Tree_Automata

section ‹Tree automaton›

theory Tree_Automata
  imports FSet_Utils
    "HOL-Library.Product_Lexorder"
    "HOL-Library.Option_ord"
begin

subsection ‹Tree automaton definition and functionality›

datatype ('q, 'f) ta_rule = TA_rule (r_root: 'f) (r_lhs_states: "'q list") (r_rhs: 'q) ("_ _ → _" [51, 51, 51] 52)
datatype ('q, 'f) ta = TA (rules: "('q, 'f) ta_rule fset") (eps: "('q × 'q) fset")

text ‹In many application we are interested in specific subset of all terms. If these
  can be captured by a tree automaton (identified by a state) then we say the set is regular.
  This gives the motivation for the following definition›
datatype ('q, 'f) reg = Reg (fin: "'q fset") (ta: "('q, 'f) ta")


text ‹The state set induced by a tree automaton is implicit in our representation.
  We compute it based on the rules and epsilon transitions of a given tree automaton›

abbreviation rule_arg_states where "rule_arg_states Δ ≡ |⋃| ((fset_of_list ∘ r_lhs_states) |`| Δ)"
abbreviation rule_target_states where "rule_target_states Δ ≡ (r_rhs |`| Δ)"
definition rule_states where "rule_states Δ ≡ rule_arg_states Δ |∪| rule_target_states Δ"

definition eps_states where "eps_states Δε ≡ (fst |`| Δε) |∪| (snd |`| Δε)"
definition "𝒬 𝒜 = rule_states (rules 𝒜) |∪| eps_states (eps 𝒜)"
abbreviation "𝒬r 𝒜 ≡ 𝒬 (ta 𝒜)"

definition ta_rhs_states :: "('q, 'f) ta ⇒ 'q fset" where
  "ta_rhs_states 𝒜 ≡ {| q | p q. (p |∈| rule_target_states (rules 𝒜)) ∧ (p = q ∨ (p, q) |∈| (eps 𝒜)|+|)|}"

definition "ta_sig 𝒜 = (λ r. (r_root r, length (r_lhs_states r))) |`| (rules 𝒜)"

subsubsection ‹Rechability of a term induced by a tree automaton›
(* The reachable states of some term. *)
fun ta_der :: "('q, 'f) ta ⇒ ('f, 'q) term ⇒ 'q fset" where
  "ta_der 𝒜 (Var q) = {|q' | q'. q = q' ∨ (q, q') |∈| (eps 𝒜)|+| |}"
| "ta_der 𝒜 (Fun f ts) = {|q' | q' q qs.
    TA_rule f qs q |∈| (rules 𝒜) ∧ (q = q' ∨ (q, q') |∈| (eps 𝒜)|+|) ∧ length qs = length ts ∧ 
    (∀ i < length ts. qs ! i |∈| ta_der 𝒜 (ts ! i))|}"

(* The reachable mixed terms of some term. *)
fun ta_der' :: "('q,'f) ta ⇒ ('f,'q) term ⇒ ('f,'q) term fset" where
  "ta_der' 𝒜 (Var p) = {|Var q | q. p = q ∨  (p, q) |∈| (eps 𝒜)|+| |}"
| "ta_der' 𝒜 (Fun f ts) = {|Var q | q. q |∈| ta_der 𝒜 (Fun f ts)|} |∪|
    {|Fun f ss | ss. length ss = length ts ∧
      (∀i < length ts. ss ! i |∈| ta_der' 𝒜 (ts ! i))|}"

text ‹Sometimes it is useful to analyse a concrete computation done by a tree automaton.
  To do this we introduce the notion of run which keeps track which states are computed in each
  subterm to reach a certain state.›

abbreviation "ex_rule_state ≡ fst ∘ groot_sym"
abbreviation "ex_comp_state ≡ snd ∘ groot_sym"

inductive run for 𝒜 where
  step: "length qs = length ts ⟹ (∀ i < length ts. run 𝒜 (qs ! i) (ts ! i)) ⟹
    TA_rule f (map ex_comp_state qs) q |∈| (rules 𝒜) ⟹ (q = q' ∨ (q, q') |∈| (eps 𝒜)|+|) ⟹ 
    run 𝒜 (GFun (q, q') qs) (GFun f ts)"


subsubsection ‹Language acceptance›

definition ta_lang :: "'q fset ⇒ ('q, 'f) ta ⇒ ('f, 'v) terms" where
  [code del]: "ta_lang Q 𝒜 = {adapt_vars t | t. ground t ∧ Q |∩| ta_der 𝒜 t ≠ {||}}"

definition gta_der where
  "gta_der 𝒜 t = ta_der 𝒜 (term_of_gterm t)"

definition gta_lang where
  "gta_lang Q 𝒜 = {t. Q |∩| gta_der 𝒜 t ≠ {||}}"

definition ℒ where
  "ℒ 𝒜 = gta_lang (fin 𝒜) (ta 𝒜)"

definition reg_Restr_Qf where
  "reg_Restr_Qf R = Reg (fin R |∩| 𝒬r R) (ta R)"

subsubsection ‹Trimming›

definition ta_restrict where
  "ta_restrict 𝒜 Q = TA {| TA_rule f qs q| f qs q. TA_rule f qs q |∈| rules 𝒜 ∧ fset_of_list qs |⊆| Q ∧ q |∈| Q |} (fRestr (eps 𝒜) Q)"

definition ta_reachable :: "('q, 'f) ta ⇒ 'q fset" where
  "ta_reachable 𝒜 = {|q| q. ∃ t. ground t ∧ q |∈| ta_der 𝒜 t |}"

definition ta_productive :: "'q fset ⇒ ('q,'f) ta ⇒ 'q fset" where
  "ta_productive P 𝒜 ≡ {|q| q q' C. q' |∈| ta_der 𝒜 (C⟨Var q⟩) ∧ q' |∈| P |}"

text ‹An automaton is trim if all its states are reachable and productive.›
definition ta_is_trim :: "'q fset ⇒ ('q, 'f) ta ⇒ bool" where
  "ta_is_trim P 𝒜 ≡ ∀ q. q |∈| 𝒬 𝒜 ⟶ q |∈| ta_reachable 𝒜 ∧ q |∈| ta_productive P 𝒜"

definition reg_is_trim :: "('q, 'f) reg ⇒ bool" where
  "reg_is_trim R ≡ ta_is_trim (fin R) (ta R)"

text ‹We obtain a trim automaton by restriction it to reachable and productive states.›
abbreviation ta_only_reach :: "('q, 'f) ta ⇒ ('q, 'f) ta" where
  "ta_only_reach 𝒜 ≡ ta_restrict 𝒜 (ta_reachable 𝒜)"

abbreviation ta_only_prod :: "'q fset ⇒ ('q,'f) ta ⇒ ('q,'f) ta" where
  "ta_only_prod P 𝒜 ≡ ta_restrict 𝒜 (ta_productive P 𝒜)"

definition reg_reach where
  "reg_reach R = Reg (fin R) (ta_only_reach (ta R))"

definition reg_prod where
  "reg_prod R = Reg (fin R) (ta_only_prod (fin R) (ta R))"

definition trim_ta :: "'q fset ⇒ ('q, 'f) ta ⇒ ('q, 'f) ta" where
  "trim_ta P 𝒜 = ta_only_prod P (ta_only_reach 𝒜)"

definition trim_reg where
  "trim_reg R = Reg (fin R) (trim_ta (fin R) (ta R))"

subsubsection ‹Mapping over tree automata›

definition fmap_states_ta ::  "('a ⇒ 'b) ⇒ ('a, 'f) ta ⇒ ('b, 'f) ta" where
  "fmap_states_ta f 𝒜 = TA (map_ta_rule f id |`| rules 𝒜) (map_both f |`| eps 𝒜)"

definition fmap_funs_ta :: "('f ⇒ 'g) ⇒ ('a, 'f) ta ⇒ ('a, 'g) ta" where
  "fmap_funs_ta f 𝒜 = TA (map_ta_rule id f |`| rules 𝒜) (eps 𝒜)"

definition fmap_states_reg ::  "('a ⇒ 'b) ⇒ ('a, 'f) reg ⇒ ('b, 'f) reg" where
  "fmap_states_reg f R = Reg (f |`| fin R) (fmap_states_ta f (ta R))"

definition fmap_funs_reg :: "('f ⇒ 'g) ⇒ ('a, 'f) reg ⇒ ('a, 'g) reg" where
  "fmap_funs_reg f R = Reg (fin R) (fmap_funs_ta f (ta R))"

subsubsection ‹Product construction (language intersection)›

definition prod_ta_rules :: "('q1,'f) ta ⇒ ('q2,'f) ta ⇒ ('q1 × 'q2, 'f) ta_rule fset" where
  "prod_ta_rules 𝒜 ℬ = {| TA_rule f qs q | f qs q. TA_rule f (map fst qs) (fst q) |∈| rules 𝒜 ∧
     TA_rule f (map snd qs) (snd q) |∈| rules ℬ|}"
declare prod_ta_rules_def [simp]


definition prod_epsLp where
  "prod_epsLp 𝒜 ℬ = (λ (p, q). (fst p, fst q) |∈| eps 𝒜 ∧ snd p = snd q ∧ snd q |∈| 𝒬 ℬ)"
definition prod_epsRp where
  "prod_epsRp 𝒜 ℬ = (λ (p, q). (snd p, snd q) |∈| eps ℬ ∧ fst p = fst q ∧ fst q |∈| 𝒬 𝒜)"

definition prod_ta :: "('q1,'f) ta ⇒ ('q2,'f) ta ⇒ ('q1 × 'q2, 'f) ta" where
  "prod_ta 𝒜 ℬ = TA (prod_ta_rules 𝒜 ℬ)
    (fCollect (prod_epsLp 𝒜 ℬ) |∪| fCollect (prod_epsRp 𝒜 ℬ))"

definition reg_intersect where
  "reg_intersect R L = Reg (fin R |×| fin L) (prod_ta (ta R) (ta L))"

subsubsection ‹Union construction (language union)›

definition ta_union where
  "ta_union 𝒜 ℬ = TA (rules 𝒜 |∪| rules ℬ) (eps 𝒜 |∪| eps ℬ)"

definition reg_union where
  "reg_union R L = Reg (Inl |`| (fin R |∩| 𝒬r R) |∪| Inr |`| (fin L |∩| 𝒬r L))
    (ta_union (fmap_states_ta Inl (ta R)) (fmap_states_ta Inr (ta L)))"


subsubsection ‹Epsilon free and tree automaton accepting empty language›

definition eps_free_rulep where
  "eps_free_rulep 𝒜 = (λ r. ∃ f qs q q'. r = TA_rule f qs q' ∧ TA_rule f qs q |∈| rules 𝒜 ∧ (q = q' ∨ (q, q') |∈| (eps 𝒜)|+|))"

definition eps_free :: "('q, 'f) ta ⇒ ('q, 'f) ta" where
  "eps_free 𝒜 = TA (fCollect (eps_free_rulep 𝒜)) {||}"

definition is_ta_eps_free :: "('q, 'f) ta ⇒ bool" where
  "is_ta_eps_free 𝒜 ⟷ eps 𝒜 = {||}"

definition ta_empty :: "'q fset ⇒ ('q,'f) ta ⇒ bool" where
  "ta_empty Q 𝒜 ⟷ ta_reachable 𝒜 |∩| Q |⊆| {||}"

definition eps_free_reg where
  "eps_free_reg R = Reg (fin R) (eps_free (ta R))"

definition reg_empty where
  "reg_empty R = ta_empty (fin R) (ta R)"


subsubsection ‹Relabeling tree automaton states to natural numbers›

definition map_fset_to_nat :: "('a :: linorder) fset ⇒ 'a ⇒ nat" where
  "map_fset_to_nat X = (λx. the (mem_idx x (sorted_list_of_fset X)))"

definition map_fset_fset_to_nat :: "('a :: linorder) fset fset ⇒ 'a fset ⇒ nat" where
  "map_fset_fset_to_nat X = (λx. the (mem_idx (sorted_list_of_fset x) (sorted_list_of_fset (sorted_list_of_fset |`| X))))"

definition relabel_ta :: "('q :: linorder, 'f) ta ⇒ (nat, 'f) ta" where
  "relabel_ta 𝒜 = fmap_states_ta (map_fset_to_nat (𝒬 𝒜)) 𝒜"

definition relabel_Qf :: "('q :: linorder) fset ⇒ ('q :: linorder, 'f) ta ⇒ nat fset" where
  "relabel_Qf Q 𝒜 = map_fset_to_nat (𝒬 𝒜) |`| (Q |∩| 𝒬 𝒜)"
definition relabel_reg  :: "('q :: linorder, 'f) reg ⇒ (nat, 'f) reg" where
  "relabel_reg R = Reg (relabel_Qf (fin R) (ta R)) (relabel_ta (ta R))"

― ‹The instantiation of $<$ and $\leq$ for finite sets are $\mid \subset \mid$ and $\mid \subseteq \mid$
  which don't give rise to a total order and therefore it cannot be an instance of the type class linorder.
  However taking the lexographic order of the sorted list of each finite set gives rise
  to a total order. Therefore we provide a relabeling for tree automata where the states
  are finite sets. This allows us to relabel the well known power set construction.›

definition relabel_fset_ta :: "(('q :: linorder) fset, 'f) ta ⇒ (nat, 'f) ta" where
  "relabel_fset_ta 𝒜 = fmap_states_ta (map_fset_fset_to_nat (𝒬 𝒜)) 𝒜"

definition relabel_fset_Qf :: "('q :: linorder) fset fset ⇒ (('q :: linorder) fset, 'f) ta ⇒ nat fset" where
  "relabel_fset_Qf Q 𝒜 = map_fset_fset_to_nat (𝒬 𝒜) |`| (Q |∩| 𝒬 𝒜)"

definition relable_fset_reg  :: "(('q :: linorder) fset, 'f) reg ⇒ (nat, 'f) reg" where
  "relable_fset_reg R = Reg (relabel_fset_Qf (fin R) (ta R)) (relabel_fset_ta (ta R))"


definition "srules 𝒜 = fset (rules 𝒜)"
definition "seps 𝒜 = fset (eps 𝒜)"

lemma rules_transfer [transfer_rule]:
  "rel_fun (=) (pcr_fset (=)) srules rules" unfolding rel_fun_def
  by (auto simp add: cr_fset_def fset.pcr_cr_eq srules_def)

lemma eps_transfer [transfer_rule]:
  "rel_fun (=) (pcr_fset (=)) seps eps" unfolding rel_fun_def
  by (auto simp add: cr_fset_def fset.pcr_cr_eq seps_def)

lemma TA_equalityI:
  "rules 𝒜 = rules ℬ ⟹ eps 𝒜 = eps ℬ ⟹ 𝒜 = ℬ"
  using ta.expand by blast

lemma rule_states_code [code]:
  "rule_states Δ = |⋃| ((λ r. finsert (r_rhs r) (fset_of_list (r_lhs_states r))) |`| Δ)"
  unfolding rule_states_def
  by fastforce

lemma eps_states_code [code]:
  "eps_states Δε = |⋃| ((λ (q,q'). {|q,q'|}) |`| Δε)" (is "?Ls = ?Rs")
  unfolding eps_states_def
  by (force simp add: case_prod_beta')

lemma rule_states_empty [simp]:
  "rule_states {||} = {||}"
  by (auto simp: rule_states_def)

lemma eps_states_empty [simp]:
  "eps_states {||} = {||}"
  by (auto simp: eps_states_def)

lemma rule_states_union [simp]:
  "rule_states (Δ |∪| Γ) = rule_states Δ |∪| rule_states Γ"
  unfolding rule_states_def
  by fastforce

lemma rule_states_mono:
  "Δ |⊆| Γ ⟹ rule_states Δ |⊆| rule_states Γ"
  unfolding rule_states_def
  by force

lemma eps_states_union [simp]:
  "eps_states (Δ |∪| Γ) = eps_states Δ |∪| eps_states Γ"
  unfolding eps_states_def
  by auto

lemma eps_states_image [simp]:
  "eps_states (map_both f |`| Δε) = f |`| eps_states Δε"
  unfolding eps_states_def map_prod_def
  by (force simp: fimage_iff)

lemma eps_states_mono:
  "Δ |⊆| Γ ⟹ eps_states Δ |⊆| eps_states Γ"
  unfolding eps_states_def
  by transfer auto

lemma eps_statesI [intro]:
  "(p, q) |∈| Δ ⟹ p |∈| eps_states Δ"
  "(p, q) |∈| Δ ⟹ q |∈| eps_states Δ"
  unfolding eps_states_def
  by (auto simp add: rev_fimage_eqI)

lemma eps_statesE [elim]:
  assumes "p |∈| eps_states Δ"
  obtains q where "(p, q) |∈| Δ ∨ (q, p) |∈| Δ" using assms
  unfolding eps_states_def
  by (transfer, auto)+

lemma rule_statesE [elim]:
  assumes "q |∈| rule_states Δ"
  obtains f ps p where "TA_rule f ps p |∈| Δ" "q |∈| (fset_of_list ps) ∨ q = p" using assms
proof -
  assume ass: "(⋀f ps p. f ps → p |∈| Δ ⟹ q |∈| fset_of_list ps ∨ q = p ⟹ thesis)"
  from assms obtain r where "r |∈| Δ" "q |∈| fset_of_list (r_lhs_states r) ∨ q = r_rhs r"
    by (auto simp: rule_states_def)
  then show thesis using ass
    by (cases r) auto
qed

lemma rule_statesI [intro]:
  assumes "r |∈| Δ" "q |∈| finsert (r_rhs r) (fset_of_list (r_lhs_states r))"
  shows "q |∈| rule_states Δ" using assms
  by (auto simp: rule_states_def)


text ‹Destruction rule for states›

lemma rule_statesD:
  "r |∈| (rules 𝒜) ⟹ r_rhs r |∈| 𝒬 𝒜" "f qs → q |∈| (rules 𝒜) ⟹ q |∈| 𝒬 𝒜"
  "r |∈| (rules 𝒜) ⟹ p |∈| fset_of_list (r_lhs_states r) ⟹ p |∈| 𝒬 𝒜"
  "f qs → q |∈| (rules 𝒜) ⟹ p |∈| fset_of_list qs ⟹ p |∈| 𝒬 𝒜"
  by (force simp: 𝒬_def rule_states_def fimage_iff)+

lemma eps_states [simp]: "(eps 𝒜) |⊆| 𝒬 𝒜 |×| 𝒬 𝒜"
  unfolding 𝒬_def eps_states_def rule_states_def
  by (auto simp add: rev_fimage_eqI)

lemma eps_statesD: "(p, q) |∈| (eps 𝒜) ⟹ p |∈| 𝒬 𝒜 ∧ q |∈| 𝒬 𝒜"
  using eps_states by (auto simp add: 𝒬_def)

lemma eps_trancl_statesD:
  "(p, q) |∈| (eps 𝒜)|+| ⟹ p |∈| 𝒬 𝒜 ∧ q |∈| 𝒬 𝒜"
  by (induct rule: ftrancl_induct) (auto dest: eps_statesD)

lemmas eps_dest_all = eps_statesD eps_trancl_statesD

text ‹Mapping over function symbols/states›

lemma finite_Collect_ta_rule:
  "finite {TA_rule f qs q | f qs q. TA_rule f qs q |∈| rules 𝒜}" (is "finite ?S")
proof -
  have "{f qs → q |f qs q. f qs → q |∈| rules 𝒜} ⊆ fset (rules 𝒜)"
    by (auto simp flip: fmember.rep_eq)
  from finite_subset[OF this] show ?thesis by simp
qed

lemma map_ta_rule_finite:
  "finite Δ ⟹ finite {TA_rule (g h) (map f qs) (f q) | h qs q. TA_rule h qs q ∈ Δ}"
proof (induct rule: finite.induct)
  case (insertI A a)
  have union: "{TA_rule (g h) (map f qs) (f q) |h qs q. TA_rule h qs q ∈ insert a A} =
    {TA_rule (g h) (map f qs) (f q) | h qs q. TA_rule h qs q = a} ∪ {TA_rule (g h) (map f qs) (f q) |h qs q. TA_rule h qs q ∈ A}"
    by auto
  have "finite {g h map f qs → f q |h qs q. h qs → q = a}"
    by (cases a) auto
  from finite_UnI[OF this insertI(2)] show ?case unfolding union .
qed auto

lemmas map_ta_rule_fset_finite [simp] = map_ta_rule_finite[of "fset Δ" for Δ, simplified, unfolded fmember.rep_eq[symmetric]]
lemmas map_ta_rule_states_finite [simp] = map_ta_rule_finite[of "fset Δ" id for Δ, simplified, unfolded fmember.rep_eq[symmetric]]
lemmas map_ta_rule_funsym_finite [simp] = map_ta_rule_finite[of "fset Δ" _ id for Δ, simplified, unfolded fmember.rep_eq[symmetric]]

lemma map_ta_rule_comp:
  "map_ta_rule f g ∘ map_ta_rule f' g' = map_ta_rule (f ∘ f') (g ∘ g')"
  using ta_rule.map_comp[of f g]
  by (auto simp: comp_def)

lemma map_ta_rule_cases:
  "map_ta_rule f g r = TA_rule (g (r_root r)) (map f (r_lhs_states r)) (f (r_rhs r))"
  by (cases r) auto

lemma map_ta_rule_prod_swap_id [simp]:
  "map_ta_rule prod.swap prod.swap (map_ta_rule prod.swap prod.swap r) = r"
  by (auto simp: map_ta_rule_cases)


lemma rule_states_image [simp]:
  "rule_states (map_ta_rule f g |`| Δ) = f |`| rule_states Δ" (is "?Ls = ?Rs")
proof -
  {fix q assume "q |∈| ?Ls"
    then obtain r where "r |∈| Δ"
      "q |∈| finsert (r_rhs (map_ta_rule f g r)) (fset_of_list (r_lhs_states (map_ta_rule f g r)))"
      by (auto simp: rule_states_def)
    then have "q |∈| ?Rs" by (cases r) (force simp: fimage_iff)}
  moreover
  {fix q assume "q |∈| ?Rs"
    then obtain r p where "r |∈| Δ" "f p = q"
      "p |∈| finsert (r_rhs r) (fset_of_list (r_lhs_states r))"
      by (auto simp: rule_states_def)
    then have "q |∈| ?Ls" by (cases r) (force simp: fimage_iff)}
  ultimately show ?thesis by blast
qed

lemma 𝒬_mono:
  "(rules 𝒜) |⊆| (rules ℬ) ⟹ (eps 𝒜) |⊆| (eps ℬ) ⟹ 𝒬 𝒜 |⊆| 𝒬 ℬ"
  using rule_states_mono eps_states_mono unfolding 𝒬_def
  by blast

lemma 𝒬_subseteq_I:
  assumes "⋀ r. r |∈| rules 𝒜 ⟹ r_rhs r |∈| S"
    and "⋀ r. r |∈| rules 𝒜 ⟹ fset_of_list (r_lhs_states r) |⊆| S"
    and "⋀ e. e |∈| eps 𝒜 ⟹ fst e |∈| S ∧ snd e |∈| S"
  shows "𝒬 𝒜 |⊆| S" using assms unfolding 𝒬_def
  by (auto simp: rule_states_def) blast

lemma finite_states:
  "finite {q. ∃ f p ps. f ps → p |∈| rules 𝒜 ∧ (p = q ∨ (p, q) |∈| (eps 𝒜)|+|)}" (is "finite ?set")
proof -
  have "?set ⊆ fset (𝒬 𝒜)"
    by (intro subsetI, drule CollectD)
       (metis eps_trancl_statesD notin_fset rule_statesD(2))
  from finite_subset[OF this] show ?thesis by auto
qed

text ‹Collecting all states reachable from target of rules›

lemma finite_ta_rhs_states [simp]:
  "finite {q. ∃p. p |∈| rule_target_states (rules 𝒜) ∧ (p = q ∨ (p, q) |∈| (eps 𝒜)|+|)}" (is "finite ?Set")
proof -
  have "?Set ⊆ fset (𝒬 𝒜)"
    by (auto dest: rule_statesD)
       (metis eps_trancl_statesD notin_fset rule_statesD(1))+
  from finite_subset[OF this] show ?thesis
    by auto
qed

text ‹Computing the signature induced by the rule set of given tree automaton›



lemma ta_sigI [intro]:
  "TA_rule f qs q |∈| (rules 𝒜) ⟹ length qs = n ⟹ (f, n) |∈| ta_sig 𝒜" unfolding ta_sig_def
  using mk_disjoint_finsert by fastforce

lemma ta_sig_mono:
  "(rules 𝒜) |⊆| (rules ℬ) ⟹ ta_sig 𝒜 |⊆| ta_sig ℬ"
  by (auto simp: ta_sig_def)

lemma finite_eps:
  "finite {q. ∃ f ps p. f ps → p |∈| rules 𝒜 ∧ (p = q ∨ (p, q) |∈| (eps 𝒜)|+|)}" (is "finite ?S")
  by (intro finite_subset[OF _ finite_ta_rhs_states[of 𝒜]]) auto

lemma collect_snd_trancl_fset:
  "{p. (q, p) |∈| (eps 𝒜)|+|} = fset (snd |`| (ffilter (λ x. fst x = q) ((eps 𝒜)|+|)))"
  by (auto simp: image_iff fmember.rep_eq) force

lemma ta_der_Var:
  "q |∈| ta_der 𝒜 (Var x) ⟷ x = q ∨ (x, q) |∈| (eps 𝒜)|+|"
  by (auto simp: collect_snd_trancl_fset)

lemma ta_der_Fun:
  "q |∈| ta_der 𝒜 (Fun f ts) ⟷ (∃ ps p. TA_rule f ps p |∈| (rules 𝒜) ∧
      (p = q ∨ (p, q) |∈| (eps 𝒜)|+|) ∧ length ps = length ts ∧ 
      (∀ i < length ts. ps ! i |∈| ta_der 𝒜 (ts ! i)))" (is "?Ls ⟷ ?Rs")
  unfolding ta_der.simps
  by (intro iffI fCollect_memberI finite_Collect_less_eq[OF _ finite_eps[of 𝒜]]) auto

declare ta_der.simps[simp del]
declare ta_der.simps[code del]
lemmas ta_der_simps [simp] = ta_der_Var ta_der_Fun

lemma ta_der'_Var:
  "Var q |∈| ta_der' 𝒜 (Var x) ⟷ x = q ∨ (x, q) |∈| (eps 𝒜)|+|"
  by (auto simp: collect_snd_trancl_fset)

lemma ta_der'_Fun:
  "Var q |∈| ta_der' 𝒜 (Fun f ts) ⟷ q |∈| ta_der 𝒜 (Fun f ts)"
  unfolding ta_der'.simps
  by (intro iffI funionI1 fCollect_memberI)
     (auto simp del: ta_der_Fun ta_der_Var simp: fset_image_conv)

lemma ta_der'_Fun2:
  "Fun f ps |∈| ta_der' 𝒜 (Fun g ts) ⟷ f = g ∧ length ps = length ts ∧ (∀i<length ts. ps ! i |∈| ta_der' 𝒜 (ts ! i))"
proof -
  have f: "finite {ss. set ss ⊆ fset ( |⋃| (fset_of_list (map (ta_der' 𝒜) ts))) ∧ length ss = length ts}"
    by (intro finite_lists_length_eq) auto
  have "finite {ss. length ss = length ts ∧ (∀i<length ts. ss ! i |∈| ta_der' 𝒜 (ts ! i))}"
    by (intro finite_subset[OF _ f])
       (force simp: in_fset_conv_nth simp flip: fset_of_list_elem fmember.rep_eq)
  then show ?thesis unfolding ta_der'.simps
    by (intro iffI funionI2 fCollect_memberI)
       (auto simp del: ta_der_Fun ta_der_Var)
qed

declare ta_der'.simps[simp del]
declare ta_der'.simps[code del]
lemmas ta_der'_simps [simp] = ta_der'_Var ta_der'_Fun ta_der'_Fun2

text ‹Induction schemes for the most used cases›

lemma ta_der_induct[consumes 1, case_names Var Fun]:
  assumes reach: "q |∈| ta_der 𝒜 t"
  and VarI: "⋀ q v. v = q ∨ (v, q) |∈| (eps 𝒜)|+| ⟹ P (Var v) q"
  and FunI: "⋀f ts ps p q. f ps → p |∈| rules 𝒜 ⟹ length ts = length ps ⟹ p = q ∨ (p, q) |∈| (eps 𝒜)|+| ⟹
    (⋀i. i < length ts ⟹ ps ! i |∈| ta_der 𝒜 (ts ! i)) ⟹
    (⋀i. i < length ts ⟹ P (ts ! i) (ps ! i)) ⟹ P (Fun f ts) q"
  shows "P t q" using assms(1)
  by (induct t arbitrary: q) (auto simp: VarI FunI)

lemma ta_der_gterm_induct[consumes 1, case_names GFun]:
  assumes reach: "q |∈| ta_der 𝒜 (term_of_gterm t)"
  and Fun: "⋀f ts ps p q. TA_rule f ps p |∈| rules 𝒜 ⟹ length ts = length ps ⟹ p = q ∨ (p, q) |∈| (eps 𝒜)|+| ⟹
    (⋀i. i < length ts ⟹ ps ! i |∈| ta_der 𝒜 (term_of_gterm (ts ! i))) ⟹
    (⋀i. i < length ts ⟹ P (ts ! i) (ps ! i)) ⟹ P (GFun f ts) q"
  shows "P t q" using assms(1)
  by (induct t arbitrary: q) (auto simp: Fun)

lemma ta_der_rule_empty:
  assumes "q |∈| ta_der (TA {||} Δε) t"
  obtains p where "t = Var p" "p = q ∨ (p, q) |∈| Δε|+|"
  using assms by (cases t) auto

lemma ta_der_eps:
  assumes "(p, q) |∈| (eps 𝒜)" and "p |∈| ta_der 𝒜 t"
  shows "q |∈| ta_der 𝒜 t" using assms
  by (cases t) (auto intro: ftrancl_into_trancl)

lemma ta_der_trancl_eps:
  assumes "(p, q) |∈| (eps 𝒜)|+|" and "p |∈| ta_der 𝒜 t"
  shows "q |∈| ta_der 𝒜 t" using assms
  by (induct rule: ftrancl_induct) (auto intro: ftrancl_into_trancl ta_der_eps)

lemma ta_der_mono:
  "(rules 𝒜) |⊆| (rules ℬ) ⟹ (eps 𝒜) |⊆| (eps ℬ) ⟹ ta_der 𝒜 t |⊆| ta_der ℬ t"
proof (induct t)
  case (Var x) then show ?case
    by (auto dest: ftrancl_mono[of _ "eps 𝒜" "eps ℬ"])
next
  case (Fun f ts)
  show ?case using Fun(1)[OF nth_mem Fun(2, 3)]
    by (auto dest!: fsubsetD[OF Fun(2)] ftrancl_mono[OF _ Fun(3)]) blast+
qed

lemma ta_der_el_mono:
  "(rules 𝒜) |⊆| (rules ℬ) ⟹ (eps 𝒜) |⊆| (eps ℬ) ⟹ q |∈| ta_der 𝒜 t ⟹ q |∈| ta_der ℬ t"
  using ta_der_mono by blast

lemma ta_der'_ta_der:
  assumes "t |∈| ta_der' 𝒜 s" "p |∈| ta_der 𝒜 t"
  shows "p |∈| ta_der 𝒜 s" using assms
proof (induction arbitrary: p t rule: ta_der'.induct)
  case (2 𝒜 f ts) show ?case using 2(2-)
  proof (induction t)
    case (Var x) then show ?case
      by auto (meson ftrancl_trans)
  next
    case (Fun g ss)
    have ss_props: "g = f" "length ss = length ts" "∀i < length ts. ss ! i |∈| ta_der' 𝒜 (ts ! i)"
      using Fun(2) by auto
    then show ?thesis using Fun(1)[OF nth_mem] Fun(2-)
      by (auto simp: ss_props)
         (metis (no_types, lifting) "2.IH" ss_props(3))+  
  qed
qed (auto dest: ftrancl_trans simp: ta_der'.simps)

lemma ta_der'_empty:
  assumes "t |∈| ta_der' (TA {||} {||}) s"
  shows "t = s" using assms
  by (induct s arbitrary: t) (auto simp add: ta_der'.simps nth_equalityI)

lemma ta_der'_to_ta_der:
  "Var q |∈| ta_der' 𝒜 s ⟹ q |∈| ta_der 𝒜 s"
  using ta_der'_ta_der by fastforce

lemma ta_der_to_ta_der':
  "q |∈| ta_der 𝒜 s ⟷ Var q |∈| ta_der' 𝒜 s "
  by (induct s arbitrary: q) auto

lemma ta_der'_poss:
  assumes "t |∈| ta_der' 𝒜 s"
  shows "poss t ⊆ poss s" using assms
proof (induct s arbitrary: t)
  case (Fun f ts)
  show ?case using Fun(2) Fun(1)[OF nth_mem, of i "args t ! i" for i]
    by (cases t) auto
qed (auto simp: ta_der'.simps)

lemma ta_der'_refl[simp]: "t |∈| ta_der' 𝒜 t"
  by (induction t) fastforce+

lemma ta_der'_eps:
  assumes "Var p |∈| ta_der' 𝒜 s" and "(p, q) |∈| (eps 𝒜)|+|"
  shows "Var q |∈| ta_der' 𝒜 s" using assms
  by (cases s, auto dest: ftrancl_trans) (meson ftrancl_trans)

lemma ta_der'_trans:
  assumes "t |∈| ta_der' 𝒜 s" and "u |∈| ta_der' 𝒜 t"
  shows "u |∈| ta_der' 𝒜 s" using assms
proof (induct t arbitrary: u s)
  case (Fun f ts) note IS = Fun(2-) note IH = Fun(1)[OF nth_mem, of i "args s ! i" for i]
  show ?case
  proof (cases s)
    case (Var x1)
    then show ?thesis using IS by (auto simp: ta_der'.simps)
  next
    case [simp]: (Fun g ss)
    show ?thesis using IS IH
      by (cases u, auto) (metis ta_der_to_ta_der')+
  qed
qed (auto simp: ta_der'.simps ta_der'_eps)

text ‹Connecting contexts to derivation definition›

lemma ta_der_ctxt:
  assumes p: "p |∈| ta_der 𝒜 t" "q |∈| ta_der 𝒜 C⟨Var p⟩"
  shows "q |∈| ta_der 𝒜 C⟨t⟩" using assms(2)
proof (induct C arbitrary: q)
  case Hole then show ?case using assms
    by (auto simp: ta_der_trancl_eps)
next
  case (More f ss C ts)
  from More(2) obtain qs r where
    rule: "f qs → r |∈| rules 𝒜" "length qs = Suc (length ss + length ts)" and
    reach: "∀ i < Suc (length ss + length ts). qs ! i |∈| ta_der 𝒜 ((ss @ C⟨Var p⟩ # ts) ! i)" "r = q ∨ (r, q) |∈| (eps 𝒜)|+|"
    by auto
  have "i < Suc (length ss + length ts) ⟹ qs ! i |∈| ta_der 𝒜 ((ss @ C⟨t⟩ # ts) ! i)" for i
    using More(1)[of "qs ! length ss"] assms rule(2) reach(1)
    unfolding nth_append_Cons by presburger
  then show ?case using rule reach(2) by auto
qed

lemma ta_der_eps_ctxt:
  assumes "p |∈| ta_der A C⟨Var q'⟩" and "(q, q') |∈| (eps A)|+|"
  shows "p |∈| ta_der A C⟨Var q⟩"
  using assms by (meson ta_der_Var ta_der_ctxt) 

lemma rule_reachable_ctxt_exist:
  assumes rule: "f qs → q |∈| rules 𝒜" and "i < length qs"
  shows "∃ C. q |∈| ta_der 𝒜 (C ⟨Var (qs ! i)⟩)" using assms
  by (intro exI[of _ "More f (map Var (take i qs)) □ (map Var (drop (Suc i) qs))"])
     (auto simp: min_def nth_append_Cons intro!: exI[of _ q] exI[of _ qs])

lemma ta_der_ctxt_decompose:
  assumes "q |∈| ta_der 𝒜 C⟨t⟩"
  shows "∃ p . p |∈| ta_der 𝒜 t ∧ q |∈| ta_der 𝒜 C⟨Var p⟩" using assms
proof (induct C arbitrary: q)
  case (More f ss C ts)
  from More(2) obtain qs r where
    rule: "f qs → r |∈| rules 𝒜" "length qs = Suc (length ss + length ts)" and
    reach: "∀ i < Suc (length ss + length ts). qs ! i |∈| ta_der 𝒜 ((ss @ C⟨t⟩ # ts) ! i)"
       "r = q ∨ (r, q) |∈| (eps 𝒜)|+|"
    by auto
  obtain p where p: "p |∈| ta_der 𝒜 t" "qs ! length ss |∈| ta_der 𝒜 C⟨Var p⟩"
    using More(1)[of "qs ! length ss"] reach(1) rule(2)
    by (metis less_add_Suc1 nth_append_length)
  have "i < Suc (length ss + length ts) ⟹ qs ! i |∈| ta_der 𝒜 ((ss @ C⟨Var p⟩ # ts) ! i)" for i
    using reach rule(2) p by (auto simp: p(2) nth_append_Cons)
  then have "q |∈| ta_der 𝒜 (More f ss C ts)⟨Var p⟩" using rule reach
    by auto
  then show ?case using p(1) by (intro exI[of _ p]) blast
qed auto

― ‹Relation between reachable states and states of a tree automaton›

lemma ta_der_states:
  "ta_der 𝒜 t |⊆| 𝒬 𝒜 |∪| fvars_term t"
proof (induct t)
  case (Var x) then show ?case
    by (auto simp: eq_onp_same_args fmember.abs_eq) 
       (metis eps_trancl_statesD)
  case (Fun f ts) then show ?case
    by (auto simp: rule_statesD(2) eps_trancl_statesD)
qed

lemma ground_ta_der_states:
  "ground t ⟹ ta_der 𝒜 t |⊆| 𝒬 𝒜"
  using ta_der_states[of 𝒜 t] by auto

lemmas ground_ta_der_statesD = fsubsetD[OF ground_ta_der_states]

lemma gterm_ta_der_states [simp]:
  "q |∈| ta_der 𝒜 (term_of_gterm t) ⟹ q |∈| 𝒬 𝒜"
  by (intro ground_ta_der_states[THEN fsubsetD, of "term_of_gterm t"]) simp

lemma ta_der_states':
  "q |∈| ta_der 𝒜 t ⟹ q |∈| 𝒬 𝒜 ⟹ fvars_term t |⊆| 𝒬 𝒜"
proof (induct rule: ta_der_induct)
  case (Fun f ts ps p r)
  then have "i < length ts ⟹ fvars_term (ts ! i) |⊆| 𝒬 𝒜" for i
    by (auto simp: in_fset_conv_nth dest!: rule_statesD(3))
  then show ?case by (force simp: in_fset_conv_nth)
qed (auto simp: eps_trancl_statesD)

lemma ta_der_not_stateD:
  "q |∈| ta_der 𝒜 t ⟹ q |∉| 𝒬 𝒜 ⟹ t = Var q"
  using fsubsetD[OF ta_der_states, of q 𝒜 t]
  by (cases t) (auto dest: rule_statesD eps_trancl_statesD)

lemma ta_der_is_fun_stateD:
  "is_Fun t ⟹ q |∈| ta_der 𝒜 t ⟹ q |∈| 𝒬 𝒜"
  using ta_der_not_stateD[of q 𝒜 t]
  by (cases t) auto

lemma ta_der_is_fun_fvars_stateD:
  "is_Fun t ⟹ q |∈| ta_der 𝒜 t ⟹ fvars_term t |⊆| 𝒬 𝒜"
  using ta_der_is_fun_stateD[of t q 𝒜]
  using ta_der_states'[of q 𝒜 t]
  by (cases t) auto

lemma ta_der_not_reach:
  assumes "⋀ r. r |∈| rules 𝒜 ⟹ r_rhs r ≠ q"
    and "⋀ e. e |∈| eps 𝒜 ⟹ snd e ≠ q"
  shows "q |∉| ta_der 𝒜 (term_of_gterm t)" using assms
  by (cases t) (fastforce dest!: assms(1) ftranclD2[of _ q])


lemma ta_rhs_states_subset_states: "ta_rhs_states 𝒜 |⊆| 𝒬 𝒜"
  by (auto simp: ta_rhs_states_def dest: rtranclD rule_statesD eps_trancl_statesD)

(* a resulting state is always some rhs of a rule (or epsilon transition) *)
lemma ta_rhs_states_res: assumes "is_Fun t" 
  shows "ta_der 𝒜 t |⊆| ta_rhs_states 𝒜"
proof
  fix q assume q: "q |∈| ta_der 𝒜 t"
  from ‹is_Fun t› obtain f ts where t: "t = Fun f ts" by (cases t, auto)
  from q[unfolded t] obtain q' qs where "TA_rule f qs q' |∈| rules 𝒜" 
    and q: "q' = q ∨ (q', q) |∈| (eps 𝒜)|+|" by auto
  then show "q |∈| ta_rhs_states 𝒜" unfolding ta_rhs_states_def
    by auto
qed

text ‹Reachable states of ground terms are preserved over the @{const adapt_vars} function›

lemma ta_der_adapt_vars_ground [simp]:
  "ground t ⟹ ta_der A (adapt_vars t) = ta_der A t"
  by (induct t) auto

lemma gterm_of_term_inv':
  "ground t ⟹ term_of_gterm (gterm_of_term t) = adapt_vars t"
  by (induct t) (auto 0 0 intro!: nth_equalityI)

lemma map_vars_term_term_of_gterm:
  "map_vars_term f (term_of_gterm t) = term_of_gterm t"
  by (induct t) auto

lemma adapt_vars_term_of_gterm:
  "adapt_vars (term_of_gterm t) = term_of_gterm t"
  by (induct t) auto

(* a term can be reduced to a state, only if all symbols appear in the automaton *)
lemma ta_der_term_sig:
  "q |∈| ta_der 𝒜 t ⟹ ffunas_term t |⊆| ta_sig 𝒜"
proof (induct rule: ta_der_induct)
  case (Fun f ts ps p q)
  show ?case using Fun(1 - 4) Fun(5)[THEN fsubsetD]
    by (auto simp: in_fset_conv_nth)
qed auto

lemma ta_der_gterm_sig:
  "q |∈| ta_der 𝒜 (term_of_gterm t) ⟹ ffunas_gterm t |⊆| ta_sig 𝒜"
  using ta_der_term_sig ffunas_term_of_gterm_conv
  by fastforce

text ‹@{const ta_lang} for terms with arbitrary variable type›

lemma ta_langE: assumes "t ∈ ta_lang Q 𝒜"
  obtains t' q where "ground t'" "q |∈| Q" "q |∈| ta_der 𝒜 t'" "t = adapt_vars t'"
  using assms unfolding ta_lang_def by blast

lemma ta_langI: assumes "ground t'" "q |∈| Q" "q |∈| ta_der 𝒜 t'" "t = adapt_vars t'"
  shows "t ∈ ta_lang Q 𝒜"
  using assms unfolding ta_lang_def by blast

lemma ta_lang_def2: "(ta_lang Q (𝒜 :: ('q,'f)ta) :: ('f,'v)terms) = {t. ground t ∧ Q |∩| ta_der 𝒜 (adapt_vars t) ≠ {||}}"
  by (auto elim!: ta_langE) (metis adapt_vars_adapt_vars ground_adapt_vars ta_langI)

text ‹@{const ta_lang} for @{const gterms}›

lemma ta_lang_to_gta_lang [simp]:
  "ta_lang Q 𝒜 = term_of_gterm ` gta_lang Q 𝒜" (is "?Ls = ?Rs")
proof -
  {fix t assume "t ∈ ?Ls"
    from ta_langE[OF this] obtain q t' where "ground t'" "q |∈| Q" "q |∈| ta_der 𝒜 t'" "t = adapt_vars t'"
      by blast
    then have "t ∈ ?Rs" unfolding gta_lang_def gta_der_def
      by (auto simp: image_iff gterm_of_term_inv' intro!: exI[of _ "gterm_of_term t'"])}
  moreover
  {fix t assume "t ∈ ?Rs" then have "t ∈ ?Ls"
      using ta_langI[OF ground_term_of_gterm _ _  gterm_of_term_inv'[OF ground_term_of_gterm]]
      by (force simp: gta_lang_def gta_der_def)}
  ultimately show ?thesis by blast
qed

lemma term_of_gterm_in_ta_lang_conv:
  "term_of_gterm t ∈ ta_lang Q 𝒜 ⟷ t ∈ gta_lang Q 𝒜"
  by (metis (mono_tags, lifting) image_iff ta_lang_to_gta_lang term_of_gterm_inv)

lemma gta_lang_def_sym:
  "gterm_of_term ` ta_lang Q 𝒜 = gta_lang Q 𝒜"
  (* this is nontrivial because the lhs has a more general type than the rhs of gta_lang_def *)
  unfolding gta_lang_def image_def
  by (intro Collect_cong) (simp add: gta_lang_def)

lemma gta_langI [intro]:
  assumes "q |∈| Q" and "q |∈| ta_der 𝒜 (term_of_gterm t)"
  shows "t ∈ gta_lang Q 𝒜" using assms
  by (metis adapt_vars_term_of_gterm ground_term_of_gterm ta_langI term_of_gterm_in_ta_lang_conv)

lemma gta_langE [elim]:
  assumes "t ∈ gta_lang Q 𝒜"
  obtains q where "q |∈| Q" and "q |∈| ta_der 𝒜 (term_of_gterm t)" using assms
  by (metis adapt_vars_adapt_vars adapt_vars_term_of_gterm ta_langE term_of_gterm_in_ta_lang_conv) 

lemma gta_lang_mono:
  assumes "⋀ t. ta_der 𝒜 t |⊆| ta_der 𝔅 t" and "Q𝒜 |⊆| Q𝔅"
  shows "gta_lang Q𝒜 𝒜 ⊆ gta_lang Q𝔅 𝔅"
  using assms by (auto elim!: gta_langE intro!: gta_langI)

lemma gta_lang_term_of_gterm [simp]:
  "term_of_gterm t ∈ term_of_gterm ` gta_lang Q 𝒜 ⟷ t ∈ gta_lang Q 𝒜"
  by (auto elim!: gta_langE intro!: gta_langI) (metis term_of_gterm_inv)

(* terms can be accepted, only if all their symbols appear in the automaton *)
lemma gta_lang_subset_rules_funas:
  "gta_lang Q 𝒜 ⊆ 𝒯G (fset (ta_sig 𝒜))"
  using ta_der_gterm_sig[THEN fsubsetD]
  by (force simp: 𝒯G_equivalent_def simp flip: fmember.rep_eq ffunas_gterm.rep_eq)

lemma reg_funas:
  "ℒ 𝒜 ⊆ 𝒯G (fset (ta_sig (ta 𝒜)))" using gta_lang_subset_rules_funas
  by (auto simp: ℒ_def)

lemma ta_syms_lang: "t ∈ ta_lang Q 𝒜 ⟹ ffunas_term t |⊆| ta_sig 𝒜"
  using gta_lang_subset_rules_funas ffunas_gterm_gterm_of_term ta_der_gterm_sig ta_lang_def2
  by fastforce

lemma gta_lang_Rest_states_conv:
  "gta_lang Q 𝒜 = gta_lang (Q |∩| 𝒬 𝒜) 𝒜"
  by (auto elim!: gta_langE)

lemma reg_Rest_fin_states [simp]:
  "ℒ (reg_Restr_Qf 𝒜) = ℒ 𝒜"
  using gta_lang_Rest_states_conv
  by (auto simp: ℒ_def reg_Restr_Qf_def)

text ‹Deterministic tree automatons›

definition ta_det :: "('q,'f) ta ⇒ bool" where
  "ta_det 𝒜 ⟷ eps 𝒜 = {||} ∧ 
    (∀ f qs q q'. TA_rule f qs q |∈| rules 𝒜 ⟶ TA_rule f qs q' |∈| rules 𝒜 ⟶ q = q')"

definition "ta_subset 𝒜 ℬ ⟷ rules 𝒜 |⊆| rules ℬ ∧ eps 𝒜 |⊆| eps ℬ"

(* determinism implies unique results *)
lemma ta_detE[elim, consumes 1]: assumes det: "ta_det 𝒜"
  shows "q |∈| ta_der 𝒜 t ⟹ q' |∈| ta_der 𝒜 t ⟹ q = q'" using assms
  by (induct t arbitrary: q q') (auto simp: ta_det_def, metis nth_equalityI nth_mem)


lemma ta_subset_states: "ta_subset 𝒜 ℬ ⟹ 𝒬 𝒜 |⊆| 𝒬 ℬ"
  using 𝒬_mono by (auto simp: ta_subset_def)

lemma ta_subset_refl[simp]: "ta_subset 𝒜 𝒜" 
  unfolding ta_subset_def by auto

lemma ta_subset_trans: "ta_subset 𝒜 ℬ ⟹ ta_subset ℬ ℭ ⟹ ta_subset 𝒜 ℭ"
  unfolding ta_subset_def by auto

lemma ta_subset_det: "ta_subset 𝒜 ℬ ⟹ ta_det ℬ ⟹ ta_det 𝒜"
  unfolding ta_det_def ta_subset_def by blast

lemma ta_der_mono': "ta_subset 𝒜 ℬ ⟹ ta_der 𝒜 t |⊆| ta_der ℬ t"
  using ta_der_mono unfolding ta_subset_def by auto

lemma ta_lang_mono': "ta_subset 𝒜 ℬ ⟹ Q𝒜 |⊆| Qℬ ⟹ ta_lang Q𝒜 𝒜 ⊆ ta_lang Qℬ ℬ"
  using gta_lang_mono[of 𝒜 ℬ] ta_der_mono'[of 𝒜 ℬ]
  by auto blast

(* the restriction of an automaton to a given set of states *)
lemma ta_restrict_subset: "ta_subset (ta_restrict 𝒜 Q) 𝒜"
  unfolding ta_subset_def ta_restrict_def
  by auto

lemma ta_restrict_states_Q: "𝒬 (ta_restrict 𝒜 Q) |⊆| Q"
  by (auto simp: 𝒬_def ta_restrict_def rule_states_def eps_states_def dest!: fsubsetD)

lemma ta_restrict_states: "𝒬 (ta_restrict 𝒜 Q) |⊆| 𝒬 𝒜"
  using ta_subset_states[OF ta_restrict_subset] by fastforce 

lemma ta_restrict_states_eq_imp_eq [simp]:
  assumes eq: "𝒬 (ta_restrict 𝒜 Q) = 𝒬 𝒜"
  shows "ta_restrict 𝒜 Q = 𝒜" using assms
  apply (auto simp: ta_restrict_def
              intro!: ta.expand finite_subset[OF _ finite_Collect_ta_rule, of _ 𝒜])
  apply (metis (no_types, lifting) eq fsubsetD fsubsetI rule_statesD(1) rule_statesD(4) ta_restrict_states_Q ta_rule.collapse)
  apply (metis eps_statesD eq fin_mono ta_restrict_states_Q)
  by (metis eps_statesD eq fsubsetD ta_restrict_states_Q)

lemma ta_der_ta_derict_states:
  "fvars_term t |⊆| Q ⟹ q |∈| ta_der (ta_restrict 𝒜 Q) t ⟹ q |∈| Q"
  by (induct t arbitrary: q) (auto simp: ta_restrict_def elim: ftranclE)

lemma ta_derict_ruleI [intro]:
  "TA_rule f qs q |∈| rules 𝒜 ⟹ fset_of_list qs |⊆| Q ⟹ q |∈| Q ⟹ TA_rule f qs q |∈| rules (ta_restrict 𝒜 Q)"
  by (auto simp: ta_restrict_def intro!: ta.expand finite_subset[OF _ finite_Collect_ta_rule, of _ 𝒜])

text ‹Reachable and productive states: There always is a trim automaton›

lemma finite_ta_reachable [simp]:
  "finite {q. ∃t. ground t ∧ q |∈| ta_der 𝒜 t}"
proof -
  have "{q. ∃t. ground t ∧ q |∈| ta_der 𝒜 t} ⊆ fset (𝒬 𝒜)"
    using ground_ta_der_states[of _ 𝒜]
    by auto (metis fsubsetD notin_fset)
  from finite_subset[OF this] show ?thesis by auto
qed

lemma ta_reachable_states:
  "ta_reachable 𝒜 |⊆| 𝒬 𝒜"
  unfolding ta_reachable_def using ground_ta_der_states
  by force

lemma ta_reachableE:
  assumes "q |∈| ta_reachable 𝒜"
  obtains t where "ground t" "q |∈| ta_der 𝒜 t"
  using assms[unfolded ta_reachable_def] by auto

lemma ta_reachable_gtermE [elim]:
  assumes "q |∈| ta_reachable 𝒜"
  obtains t where "q |∈| ta_der 𝒜 (term_of_gterm t)"
  using ta_reachableE[OF assms]
  by (metis ground_term_to_gtermD) 

lemma ta_reachableI [intro]:
  assumes "ground t" and "q |∈| ta_der 𝒜 t"
  shows "q |∈| ta_reachable 𝒜"
  using assms finite_ta_reachable
  by (auto simp: ta_reachable_def)

lemma ta_reachable_gtermI [intro]:
  "q |∈| ta_der 𝒜 (term_of_gterm t) ⟹ q |∈| ta_reachable 𝒜"
  by (intro ta_reachableI[of "term_of_gterm t"]) simp

lemma ta_reachableI_rule:
  assumes sub: "fset_of_list qs |⊆| ta_reachable 𝒜"
    and rule: "TA_rule f qs q |∈| rules 𝒜"
  shows "q |∈| ta_reachable 𝒜"
    "∃ ts. length qs = length ts ∧ (∀ i < length ts. ground (ts ! i)) ∧
      (∀ i < length ts. qs ! i |∈| ta_der 𝒜 (ts ! i))" (is "?G")
proof -
  {
    fix i
    assume i: "i < length qs"
    then have "qs ! i |∈| fset_of_list qs" by auto
    with sub have "qs ! i |∈| ta_reachable 𝒜" by auto
    from ta_reachableE[OF this] have "∃ t. ground t ∧ qs ! i |∈| ta_der 𝒜 t" by auto
  }
  then have "∀ i. ∃ t. i < length qs ⟶ ground t ∧ qs ! i |∈| ta_der 𝒜 t" by auto
  from choice[OF this] obtain ts where ts: "⋀ i. i < length qs ⟹ ground (ts i) ∧ qs ! i |∈| ta_der 𝒜 (ts i)" by blast
  let ?t = "Fun f (map ts [0 ..< length qs])"
  have gt: "ground ?t" using ts by auto
  have r: "q |∈| ta_der 𝒜 ?t" unfolding ta_der_Fun using rule ts
    by (intro exI[of _ qs] exI[of _ q]) simp
  with gt show "q |∈| ta_reachable 𝒜" by blast
  from gt ts show ?G by (intro exI[of _ "map ts [0..<length qs]"]) simp
qed

lemma ta_reachable_rule_gtermE:
  assumes "𝒬 𝒜 |⊆| ta_reachable 𝒜"
    and "TA_rule f qs q |∈| rules 𝒜"
  obtains t where "groot t = (f, length qs)" "q |∈| ta_der 𝒜 (term_of_gterm t)"
proof -
  assume *: "⋀t. groot t = (f, length qs) ⟹ q |∈| ta_der 𝒜 (term_of_gterm t) ⟹ thesis"
  from assms have "fset_of_list qs |⊆| ta_reachable 𝒜"
    by (auto dest: rule_statesD(3))
  from ta_reachableI_rule[OF this assms(2)] obtain ts where args: "length qs = length ts"
    "∀ i < length ts. ground (ts ! i)" "∀ i < length ts. qs ! i |∈| ta_der 𝒜 (ts ! i)"
    using assms by force
  then show ?thesis using assms(2)
    by (intro *[of "GFun f (map gterm_of_term ts)"]) auto
qed

lemma ta_reachableI_eps':
  assumes reach: "q |∈| ta_reachable 𝒜"
    and eps: "(q, q') |∈| (eps 𝒜)|+|"  
  shows "q' |∈| ta_reachable 𝒜"
proof -
  from ta_reachableE[OF reach] obtain t where g: "ground t" and res: "q |∈| ta_der 𝒜 t" by auto
  from ta_der_trancl_eps[OF eps res] g show ?thesis by blast
qed

lemma ta_reachableI_eps:
  assumes reach: "q |∈| ta_reachable 𝒜"
    and eps: "(q, q') |∈| eps 𝒜"  
  shows "q' |∈| ta_reachable 𝒜"
  by (rule ta_reachableI_eps'[OF reach], insert eps, auto)

― ‹Automata are productive on a set P if all states can reach a state in P›


lemma finite_ta_productive:
  "finite {p. ∃q q' C. p = q ∧ q' |∈| ta_der 𝒜 C⟨Var q⟩ ∧ q' |∈| P}"
proof -
  {fix x q C assume ass: "x ∉ fset P" "q |∈| P" "q |∈| ta_der 𝒜 C⟨Var x⟩"
    then have "x ∈ fset (𝒬 𝒜)"
    proof (cases "is_Fun C⟨Var x⟩")
      case True
      then show ?thesis using ta_der_is_fun_fvars_stateD[OF _ ass(3)]
        by auto (metis notin_fset)
    next
      case False
      then show ?thesis using ass
        by (cases C, auto, (metis eps_trancl_statesD notin_fset)+)
    qed}
  then have "{q | q q' C. q' |∈| ta_der 𝒜 (C⟨Var q⟩) ∧ q' |∈| P} ⊆ fset (𝒬 𝒜) ∪ fset P" by auto
  from finite_subset[OF this] show ?thesis by auto
qed

lemma ta_productiveE: assumes "q |∈| ta_productive P 𝒜"
  obtains q' C where "q' |∈| ta_der 𝒜 (C⟨Var q⟩)" "q' |∈| P" 
  using assms[unfolded ta_productive_def] by auto

lemma ta_productiveI:
  assumes "q' |∈| ta_der 𝒜 (C⟨Var q⟩)" "q' |∈| P" 
  shows "q |∈| ta_productive P 𝒜"
  using assms unfolding ta_productive_def
  using finite_ta_productive
  by auto

lemma ta_productiveI': 
  assumes "q |∈| ta_der 𝒜 (C⟨Var p⟩)" "q |∈| ta_productive P 𝒜" 
  shows "p |∈| ta_productive P 𝒜"
  using assms unfolding ta_productive_def
  by auto (metis (mono_tags, lifting) ctxt_ctxt_compose ta_der_ctxt)

lemma ta_productive_setI:
  "q |∈| P ⟹ q |∈| ta_productive P 𝒜"
  using ta_productiveI[of q 𝒜 □ q]
  by simp


lemma ta_reachable_empty_rules [simp]:
  "rules 𝒜 = {||} ⟹ ta_reachable 𝒜 = {||}"
  by (auto simp: ta_reachable_def)
     (metis ground.simps(1) ta.exhaust_sel ta_der_rule_empty)

lemma ta_reachable_mono:
  "ta_subset 𝒜 ℬ ⟹ ta_reachable 𝒜 |⊆| ta_reachable ℬ" using ta_der_mono'
  by (auto simp: ta_reachable_def) blast

lemma ta_reachabe_rhs_states: 
  "ta_reachable 𝒜 |⊆| ta_rhs_states 𝒜"
proof -
  {fix q assume "q |∈| ta_reachable 𝒜"
    then obtain t where "ground t" "q |∈| ta_der 𝒜 t"
      by (auto simp: ta_reachable_def)
    then have "q |∈| ta_rhs_states 𝒜"
      by (cases t) (auto simp: ta_rhs_states_def)}
  then show ?thesis by blast
qed

lemma ta_reachable_eps:
  "(p, q) |∈| (eps 𝒜)|+| ⟹ p |∈| ta_reachable 𝒜 ⟹ (p, q) |∈| (fRestr (eps 𝒜) (ta_reachable 𝒜))|+|"
proof (induct rule: ftrancl_induct)
  case (Base a b)
  then show ?case
    by (metis fSigmaI finterI fr_into_trancl ta_reachableI_eps)
next
  case (Step p q r)
  then have "q |∈| ta_reachable 𝒜" "r |∈| ta_reachable 𝒜"
    by (metis ta_reachableI_eps ta_reachableI_eps')+
  then show ?case using Step
    by (metis fSigmaI finterI ftrancl_into_trancl)
qed

(* major lemma to show that one can restrict to reachable states *)
lemma ta_der_only_reach:
  assumes "fvars_term t |⊆| ta_reachable 𝒜"
  shows "ta_der 𝒜 t = ta_der (ta_only_reach 𝒜) t" (is "?LS = ?RS")
proof -
  have "?RS |⊆| ?LS" using ta_der_mono'[OF ta_restrict_subset]
    by fastforce
  moreover
  {fix q assume "q |∈| ?LS"
    then have "q |∈| ?RS" using assms
    proof (induct rule: ta_der_induct)
      case (Fun f ts ps p q)
      from Fun(2, 6) have ta_reach [simp]: "i < length ps ⟹ fvars_term (ts ! i) |⊆| ta_reachable 𝒜" for i
        by auto (metis ffUnionI fimage_fset fnth_mem funionI2 length_map nth_map sup.orderE) 
      from Fun have r: "i < length ts ⟹ ps ! i |∈| ta_der (ta_only_reach 𝒜) (ts ! i)"
        "i < length ts ⟹ ps ! i |∈| ta_reachable 𝒜" for i
        by (auto) (metis ta_reach ta_der_ta_derict_states)+
      then have "f ps → p |∈| rules (ta_only_reach 𝒜)"
        using Fun(1, 2)
        by (intro ta_derict_ruleI)
           (fastforce simp: in_fset_conv_nth intro!: ta_reachableI_rule[OF _ Fun(1)])+
      then show ?case using ta_reachable_eps[of p q] ta_reachableI_rule[OF _ Fun(1)] r Fun(2, 3)
        by (auto simp: ta_restrict_def intro!: exI[of _ p] exI[of _ ps])
    qed (auto simp: ta_restrict_def intro: ta_reachable_eps)}
  ultimately show ?thesis by blast
qed

lemma ta_der_gterm_only_reach:
  "ta_der 𝒜 (term_of_gterm t) = ta_der (ta_only_reach 𝒜) (term_of_gterm t)"
  using ta_der_only_reach[of "term_of_gterm t" 𝒜]
  by simp

lemma ta_reachable_ta_only_reach [simp]:
  "ta_reachable (ta_only_reach 𝒜) = ta_reachable 𝒜"  (is "?LS = ?RS")
proof -
  have "?LS |⊆| ?RS" using ta_der_mono'[OF ta_restrict_subset]
    by (auto simp: ta_reachable_def) fastforce
  moreover
  {fix t assume "ground (t :: ('b, 'a) term)"
    then have "ta_der 𝒜 t = ta_der (ta_only_reach 𝒜) t" using ta_der_only_reach[of t 𝒜]
      by simp}
  ultimately show ?thesis unfolding ta_reachable_def
    by auto
qed

lemma ta_only_reach_reachable:
  "𝒬 (ta_only_reach 𝒜) |⊆| ta_reachable (ta_only_reach 𝒜)"
  using ta_restrict_states_Q[of 𝒜 "ta_reachable 𝒜"]
  by auto

(* It is sound to restrict to reachable states. *)
lemma gta_only_reach_lang:
  "gta_lang Q (ta_only_reach 𝒜) = gta_lang Q 𝒜"
  using ta_der_gterm_only_reach
  by (auto elim!: gta_langE intro!: gta_langI) force+


lemma ℒ_only_reach: "ℒ (reg_reach R) = ℒ R"
  using gta_only_reach_lang
  by (auto simp: ℒ_def reg_reach_def)

lemma ta_only_reach_lang:
  "ta_lang Q (ta_only_reach 𝒜) = ta_lang Q 𝒜"
  using gta_only_reach_lang
  by (metis ta_lang_to_gta_lang)


lemma ta_prod_epsD:
  "(p, q) |∈| (eps 𝒜)|+| ⟹ q |∈| ta_productive P 𝒜 ⟹ p |∈| ta_productive P 𝒜"
  using ta_der_ctxt[of q 𝒜 "□⟨Var p⟩"]
  by (auto simp: ta_productive_def ta_der_trancl_eps)

lemma ta_only_prod_eps:
  "(p, q) |∈| (eps 𝒜)|+| ⟹ q |∈| ta_productive P 𝒜 ⟹ (p, q) |∈| (eps (ta_only_prod P 𝒜))|+|"
proof (induct rule: ftrancl_induct)
  case (Base p q)
  then show ?case
    by (metis (no_types, lifting) fSigmaI finterI fr_into_trancl ta.sel(2) ta_prod_epsD ta_restrict_def)
next
  case (Step p q r) note IS = this
  show ?case using IS(2 - 4) ta_prod_epsD[OF fr_into_trancl[OF IS(3)] IS(4)] 
    by (auto simp: ta_restrict_def) (simp add: ftrancl_into_trancl)
qed

(* Major lemma to show that it is sound to restrict to productive states. *)
lemma ta_der_only_prod: 
  "q |∈| ta_der 𝒜 t ⟹ q |∈| ta_productive P 𝒜 ⟹ q |∈| ta_der (ta_only_prod P 𝒜) t"
proof (induct rule: ta_der_induct)
  case (Fun f ts ps p q)
  let ?𝒜 = "ta_only_prod P 𝒜"
  have pr: "p |∈| ta_productive P 𝒜" "i < length ts ⟹ ps ! i |∈| ta_productive P 𝒜" for i
    using Fun(2) ta_prod_epsD[of p q] Fun(3, 6) rule_reachable_ctxt_exist[OF Fun(1)]
    using ta_productiveI'[of p 𝒜 _ "ps ! i" P]
    by auto
  then have "f ps → p |∈| rules ?𝒜" using Fun(1, 2) unfolding ta_restrict_def
    by (auto simp: in_fset_conv_nth intro: finite_subset[OF _ finite_Collect_ta_rule, of _ 𝒜])
  then show ?case using pr Fun ta_only_prod_eps[of p q 𝒜 P] Fun(3, 6)
    by auto
qed (auto intro: ta_only_prod_eps)

lemma ta_der_ta_only_prod_ta_der:
  "q |∈| ta_der (ta_only_prod P 𝒜) t ⟹ q |∈| ta_der 𝒜 t"
  by (meson ta_der_el_mono ta_restrict_subset ta_subset_def)


(* It is sound to restrict to productive states. *)
lemma gta_only_prod_lang:
  "gta_lang Q (ta_only_prod Q 𝒜) = gta_lang Q 𝒜" (is "gta_lang Q ?𝒜 = _")
proof
  show "gta_lang Q ?𝒜 ⊆ gta_lang Q 𝒜"
    using gta_lang_mono[OF ta_der_mono'[OF ta_restrict_subset]]
    by blast
next
  {fix t assume "t ∈ gta_lang Q 𝒜"
    from gta_langE[OF this] obtain q where
      reach: "q |∈| ta_der 𝒜 (term_of_gterm t)" "q |∈| Q" .
    from ta_der_only_prod[OF reach(1) ta_productive_setI[OF reach(2)]] reach(2)
    have "t ∈ gta_lang Q ?𝒜" by (auto intro: gta_langI)}
  then show "gta_lang Q 𝒜 ⊆ gta_lang Q ?𝒜" by blast
qed

lemma ℒ_only_prod: "ℒ (reg_prod R) = ℒ R"
  using gta_only_prod_lang
  by (auto simp: ℒ_def reg_prod_def)

lemma ta_only_prod_lang:
  "ta_lang Q (ta_only_prod Q 𝒜) = ta_lang Q 𝒜"
  using gta_only_prod_lang
  by (metis ta_lang_to_gta_lang)

(* the productive states are also productive w.r.t. the new automaton *)
lemma ta_prodictive_ta_only_prod [simp]:
  "ta_productive P (ta_only_prod P 𝒜) = ta_productive P 𝒜"  (is "?LS = ?RS")
proof -
  have "?LS |⊆| ?RS" using ta_der_mono'[OF ta_restrict_subset]
    using finite_ta_productive[of 𝒜 P]
    by (auto simp: ta_productive_def) fastforce
  moreover have "?RS |⊆| ?LS" using ta_der_only_prod
    by (auto elim!: ta_productiveE)
       (smt (z3) ta_der_only_prod ta_productiveI ta_productive_setI)
  ultimately show ?thesis by blast
qed

lemma ta_only_prod_productive:
  "𝒬 (ta_only_prod P 𝒜) |⊆| ta_productive P (ta_only_prod P 𝒜)"
  using ta_restrict_states_Q by force

lemma ta_only_prod_reachable:
  assumes all_reach: "𝒬 𝒜 |⊆| ta_reachable 𝒜"
  shows "𝒬 (ta_only_prod P 𝒜) |⊆| ta_reachable (ta_only_prod P 𝒜)" (is "?Ls |⊆| ?Rs")
proof -
  {fix q assume "q |∈| ?Ls"
    then obtain t where "ground t" "q |∈| ta_der 𝒜 t" "q |∈| ta_productive P 𝒜"
      using fsubsetD[OF ta_only_prod_productive[of 𝒜 P]]
      using fsubsetD[OF fsubset_trans[OF ta_restrict_states all_reach, of "ta_productive P 𝒜"]]
      by (auto elim!: ta_reachableE)
    then have "q |∈| ?Rs"
      by (intro ta_reachableI[where ?𝒜 = "ta_only_prod P 𝒜" and ?t = t]) (auto simp: ta_der_only_prod)}
  then show ?thesis by blast
qed

lemma ta_prod_reach_subset:
  "ta_subset (ta_only_prod P (ta_only_reach 𝒜)) 𝒜"
  by (rule ta_subset_trans, (rule ta_restrict_subset)+)

lemma ta_prod_reach_states:
  "𝒬 (ta_only_prod P (ta_only_reach 𝒜)) |⊆| 𝒬 𝒜"
  by (rule ta_subset_states[OF ta_prod_reach_subset])

(* If all states are reachable then there exists a ground context for all productive states *)
lemma ta_productive_aux:
  assumes "𝒬 𝒜 |⊆| ta_reachable 𝒜" "q |∈| ta_der 𝒜 (C⟨t⟩)"
  shows "∃C'. ground_ctxt C' ∧ q |∈| ta_der 𝒜 (C'⟨t⟩)" using assms(2)
proof (induct C arbitrary: q)
  case Hole then show ?case by (intro exI[of _ "□"]) auto
next
  case (More f ts1 C ts2)
  from More(2) obtain qs q' where q': "f qs → q' |∈| rules 𝒜" "q' = q ∨ (q', q) |∈| (eps 𝒜)|+|"
    "qs ! length ts1 |∈| ta_der 𝒜 (C⟨t⟩)" "length qs = Suc (length ts1 + length ts2)"
    by simp (metis less_add_Suc1 nth_append_length)
  { fix i assume "i < length qs"
    then have "qs ! i |∈| 𝒬 𝒜" using q'(1)
      by (auto dest!: rule_statesD(4))
    then have "∃t. ground t ∧ qs ! i |∈| ta_der 𝒜 t" using assms(1)
      by (simp add: ta_reachable_def) force}
  then obtain ts where ts: "i < length qs ⟹ ground (ts i) ∧ qs ! i |∈| ta_der 𝒜 (ts i)" for i by metis
  obtain C' where C: "ground_ctxt C'" "qs ! length ts1 |∈| ta_der 𝒜 C'⟨t⟩" using More(1)[OF q'(3)] by blast
  define D where "D ≡ More f (map ts [0..<length ts1]) C' (map ts [Suc (length ts1)..<Suc (length ts1 + length ts2)])"
  have "ground_ctxt D" unfolding D_def using ts C(1) q'(4) by auto
  moreover have "q |∈| ta_der 𝒜 D⟨t⟩" using ts C(2) q' unfolding D_def
    by (auto simp: nth_append_Cons not_le not_less le_less_Suc_eq Suc_le_eq intro!: exI[of _ qs] exI[of _ q'])
  ultimately show ?case by blast
qed

lemma ta_productive_def':
  assumes "𝒬 𝒜 |⊆| ta_reachable 𝒜"
  shows "ta_productive Q 𝒜 = {| q| q q' C. ground_ctxt C ∧ q' |∈| ta_der 𝒜 (C⟨Var q⟩) ∧ q' |∈| Q |}"
  using ta_productive_aux[OF assms]
  by (auto simp: ta_productive_def intro!: finite_subset[OF _ finite_ta_productive, of _ 𝒜 Q]) force+

(* turn a finite automaton into a trim one, by removing
   first all unreachable and then all non-productive states *)

lemma trim_gta_lang: "gta_lang Q (trim_ta Q 𝒜) = gta_lang Q 𝒜"
  unfolding trim_ta_def gta_only_reach_lang gta_only_prod_lang ..

lemma trim_ta_subset: "ta_subset (trim_ta Q 𝒜) 𝒜"
  unfolding trim_ta_def by (rule ta_prod_reach_subset)

theorem trim_ta: "ta_is_trim Q (trim_ta Q 𝒜)" unfolding ta_is_trim_def
  by (metis fin_mono ta_only_prod_reachable ta_only_reach_reachable
      ta_prodictive_ta_only_prod ta_restrict_states_Q trim_ta_def)


lemma reg_is_trim_trim_reg [simp]: "reg_is_trim (trim_reg R)"
  unfolding reg_is_trim_def trim_reg_def
  by (simp add: trim_ta)

lemma trim_reg_reach [simp]:
  "𝒬r (trim_reg A) |⊆| ta_reachable (ta (trim_reg A))"
  by (auto simp: trim_reg_def) (meson ta_is_trim_def trim_ta)

lemma trim_reg_prod [simp]:
  "𝒬r (trim_reg A) |⊆| ta_productive (fin (trim_reg A)) (ta (trim_reg A))"
  by (auto simp: trim_reg_def) (meson ta_is_trim_def trim_ta)

(* Proposition 7: every tree automaton can be turned into an  equivalent trim one *)
lemmas obtain_trimmed_ta = trim_ta trim_gta_lang ta_subset_det[OF trim_ta_subset]

(* Trim tree automaton signature *)
lemma ℒ_trim_ta_sig:
  assumes "reg_is_trim R" "ℒ R ⊆ 𝒯G (fset ℱ)"
  shows "ta_sig (ta R) |⊆| ℱ"
proof -
  {fix r assume r: "r |∈| rules (ta R)"
    then obtain f ps p where [simp]: "r = f ps → p" by (cases r) auto
    from r assms(1) have "fset_of_list ps |⊆| ta_reachable (ta R)"
      by (auto simp add: rule_statesD(4) reg_is_trim_def ta_is_trim_def)
    from ta_reachableI_rule[OF this, of f p] r
    obtain ts where ts: "length ts = length ps" "∀ i < length ps. ground (ts ! i)"
      "∀ i < length ps. ps ! i |∈| ta_der (ta R) (ts ! i)"
      by auto
    obtain C q where ctxt: "ground_ctxt C" "q |∈| ta_der (ta R) (C⟨Var p⟩)" "q |∈| fin R"
      using assms(1) unfolding reg_is_trim_def
      by (metis ‹r = f ps → p› fsubsetI r rule_statesD(2) ta_productiveE ta_productive_aux ta_is_trim_def)
    from ts ctxt r have reach: "q |∈| ta_der (ta R) C⟨Fun f ts⟩"
      by auto (metis ta_der_Fun ta_der_ctxt)
    have gr: "ground C⟨Fun f ts⟩" using ts(1, 2) ctxt(1)
      by (auto simp: in_set_conv_nth)
    then have "C⟨Fun f ts⟩ ∈ ta_lang (fin R) (ta R)" using ctxt(1, 3) ts(1, 2)
      apply (intro ta_langI[OF _ _ reach, of "fin R" "C⟨Fun f ts⟩"])
      apply (auto simp del: adapt_vars_ctxt)
      by (metis gr adapt_vars2 adapt_vars_adapt_vars)
    then have *: "gterm_of_term C⟨Fun f ts⟩ ∈ ℒ R" using gr
      by (auto simp: ℒ_def)
    then have "funas_gterm (gterm_of_term C⟨Fun f ts⟩) ⊆ fset ℱ" using assms(2) gr
      by (auto simp: 𝒯G_equivalent_def)
    moreover have "(f, length ps) ∈ funas_gterm (gterm_of_term C⟨Fun f ts⟩)"
      using ts(1) by (auto simp: funas_gterm_gterm_of_term[OF gr])
    ultimately have "(r_root r, length (r_lhs_states r)) |∈| ℱ"
      by (auto simp: fmember.rep_eq)}
  then show ?thesis
    by (auto simp: ta_sig_def)
qed

text ‹Map function over TA rules which change states/signature›

lemma map_ta_rule_iff:
  "map_ta_rule f g |`| Δ = {|TA_rule (g h) (map f qs) (f q) | h qs q. TA_rule h qs q |∈| Δ|}"
  apply (intro fequalityI fsubsetI)
  apply (auto simp add: rev_fimage_eqI)
  apply (metis map_ta_rule_cases ta_rule.collapse)
  done

lemma ℒ_trim: "ℒ (trim_reg R) = ℒ R"
  by (auto simp: trim_gta_lang ℒ_def trim_reg_def)


lemma fmap_funs_ta_def':
  "fmap_funs_ta h 𝒜 = TA {|(h f) qs → q |f qs q. f qs → q |∈| rules 𝒜|} (eps 𝒜)"
  unfolding fmap_funs_ta_def map_ta_rule_iff by auto

lemma fmap_states_ta_def':
  "fmap_states_ta h 𝒜 = TA {|f (map h qs) → h q |f qs q. f qs → q |∈| rules 𝒜|} (map_both h |`| eps 𝒜)"
  unfolding fmap_states_ta_def map_ta_rule_iff by auto

lemma fmap_states [simp]:
  "𝒬 (fmap_states_ta h 𝒜) = h |`| 𝒬 𝒜"
  unfolding fmap_states_ta_def 𝒬_def
  by auto

lemma fmap_states_ta_sig [simp]:
  "ta_sig (fmap_states_ta f 𝒜) = ta_sig 𝒜"
  by (auto simp: fBex_def fmap_states_ta_def ta_sig_def fimage_iff)
     (metis id_def length_map ta_rule.map_sel(1, 2))+

lemma fmap_states_ta_eps_wit:
  assumes "(h p, q) |∈| (map_both h |`| eps 𝒜)|+|" "finj_on h (𝒬 𝒜)" "p |∈| 𝒬 𝒜"
  obtains q' where "q = h q'" "(p, q') |∈| (eps 𝒜)|+|" "q' |∈| 𝒬 𝒜" using assms
  by (auto simp: fimage_iff finj_on_def' ftrancl_map_both_fsubset[OF assms(2), of "eps 𝒜"])
     (metis (mono_tags, lifting) assms(2) eps_trancl_statesD finj_on_eq_iff)

lemma ta_der_fmap_states_inv_superset:
  assumes "𝒬 𝒜 |⊆| ℬ" "finj_on h ℬ"
    and  "q |∈| ta_der (fmap_states_ta h 𝒜) (term_of_gterm t)"
  shows "the_finv_into ℬ h q |∈| ta_der 𝒜 (term_of_gterm t)" using assms(3)
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  from assms(1, 2) have inj: "finj_on h (𝒬 𝒜)" using fsubset_finj_on by blast
  have "x |∈| 𝒬 𝒜 ⟹ the_finv_into (𝒬 𝒜) h (h x) = the_finv_into ℬ h (h x)" for x
    using assms(1, 2) by (metis fsubsetD inj the_finv_into_f_f) 
  then show ?case using GFun the_finv_into_f_f[OF inj] assms(1)
    by (auto simp: fmap_states_ta_def' finj_on_def' rule_statesD eps_statesD
      elim!: fmap_states_ta_eps_wit[OF _ inj]
      intro!: exI[of _ "the_finv_into ℬ h p"])
qed

lemma ta_der_fmap_states_inv:
  assumes "finj_on h (𝒬 𝒜)" "q |∈| ta_der (fmap_states_ta h 𝒜) (term_of_gterm t)"
  shows "the_finv_into (𝒬 𝒜) h q |∈| ta_der 𝒜 (term_of_gterm t)"
  by (simp add: ta_der_fmap_states_inv_superset assms)

lemma ta_der_to_fmap_states_der:
  assumes "q |∈| ta_der 𝒜 (term_of_gterm t)"
  shows "h q |∈| ta_der (fmap_states_ta h 𝒜) (term_of_gterm t)" using assms
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  then show ?case
    using ftrancl_map_prod_mono[of h "eps 𝒜"]
    by (auto simp: fmap_states_ta_def' intro!: exI[of _ "h p"] exI[of _ "map h ps"])
qed

lemma ta_der_fmap_states_conv:
  assumes "finj_on h (𝒬 𝒜)"
  shows "ta_der (fmap_states_ta h 𝒜) (term_of_gterm t) =  h |`| ta_der 𝒜 (term_of_gterm t)"
  using ta_der_to_fmap_states_der[of _ 𝒜 t] ta_der_fmap_states_inv[OF assms]
  using f_the_finv_into_f[OF assms] finj_on_the_finv_into[OF assms]
  using gterm_ta_der_states
  by (auto intro!: rev_fimage_eqI) fastforce

lemma fmap_states_ta_det:
  assumes "finj_on f (𝒬 𝒜)"
  shows "ta_det (fmap_states_ta f 𝒜) = ta_det 𝒜" (is "?Ls = ?Rs")
proof
  {fix g ps p q assume ass: "?Ls" "TA_rule g ps p |∈| rules 𝒜" "TA_rule g ps q |∈| rules 𝒜"
    then have "TA_rule g (map f ps) (f p) |∈| rules (fmap_states_ta f 𝒜)"
       "TA_rule g (map f ps) (f q) |∈| rules (fmap_states_ta f 𝒜)"
      by (force simp: fmap_states_ta_def)+
    then have "p = q" using ass finj_on_eq_iff[OF assms]
      by (auto simp: ta_det_def) (meson rule_statesD(2))} 
  then show "?Ls ⟹ ?Rs"
    by (auto simp: ta_det_def fmap_states_ta_def')
next
  {fix g ps qs p q assume ass: "?Rs" "TA_rule g ps p |∈| rules 𝒜" "TA_rule g qs q |∈| rules 𝒜"
    then have "map f ps = map f qs ⟹ ps = qs" using finj_on_eq_iff[OF assms]
      by (auto simp: map_eq_nth_conv in_fset_conv_nth dest!: rule_statesD(4) intro!: nth_equalityI)}
  then show "?Rs ⟹ ?Ls" using finj_on_eq_iff[OF assms]
    by (auto simp: ta_det_def fmap_states_ta_def') blast
qed

lemma fmap_states_ta_lang:
  "finj_on f (𝒬 𝒜) ⟹ Q |⊆| 𝒬 𝒜 ⟹ gta_lang (f |`| Q) (fmap_states_ta f 𝒜) = gta_lang Q 𝒜"
  using ta_der_fmap_states_conv[of f 𝒜]
  by (auto simp: finj_on_def' finj_on_eq_iff fsubsetD elim!: gta_langE intro!: gta_langI)

lemma fmap_states_ta_lang2:
  "finj_on f (𝒬 𝒜 |∪| Q) ⟹ gta_lang (f |`| Q) (fmap_states_ta f 𝒜) = gta_lang Q 𝒜"
  using ta_der_fmap_states_conv[OF fsubset_finj_on[of f "𝒬 𝒜 |∪| Q" "𝒬 𝒜"]] 
  by (auto simp: finj_on_def' elim!: gta_langE intro!: gta_langI) fastforce


definition funs_ta :: "('q, 'f) ta ⇒ 'f fset" where
  "funs_ta 𝒜 = {|f |f qs q. TA_rule f qs q |∈| rules 𝒜|}"

lemma funs_ta[code]:
  "funs_ta 𝒜 = (λ r. case r of TA_rule f ps p ⇒ f) |`| (rules 𝒜)" (is "?Ls = ?Rs")
  by (force simp: funs_ta_def rev_fimage_eqI simp flip: fset.set_map fmember.rep_eq
     split!: ta_rule.splits intro!: finite_subset[of "{f. ∃qs q. TA_rule f qs q |∈| rules 𝒜}" "fset ?Rs"])

lemma finite_funs_ta [simp]:
  "finite {f. ∃qs q. TA_rule f qs q |∈| rules 𝒜}"
  by (intro finite_subset[of "{f. ∃qs q. TA_rule f qs q |∈| rules 𝒜}" "fset (funs_ta 𝒜)"])
     (auto simp: funs_ta rev_fimage_eqI simp flip: fset.set_map fmember.rep_eq split!: ta_rule.splits)

lemma funs_taE [elim]:
  assumes "f |∈| funs_ta 𝒜"
  obtains ps p where "TA_rule f ps p |∈| rules 𝒜" using assms
  by (auto simp: funs_ta_def)

lemma funs_taI [intro]:
  "TA_rule f ps p |∈| rules 𝒜 ⟹ f |∈| funs_ta 𝒜"
  by (auto simp: funs_ta_def)

lemma fmap_funs_ta_cong:
  "(⋀x. x |∈| funs_ta 𝒜 ⟹ h x = k x) ⟹ 𝒜 = ℬ ⟹ fmap_funs_ta h 𝒜 = fmap_funs_ta k ℬ"
  by (force simp: fmap_funs_ta_def')

lemma [simp]: "{|TA_rule f qs q |f qs q. TA_rule f qs q |∈| X|} = X"
  by (intro fset_eqI; case_tac x) auto

lemma fmap_funs_ta_id [simp]:
  "fmap_funs_ta id 𝒜 = 𝒜" by (simp add: fmap_funs_ta_def')

lemma fmap_states_ta_id [simp]:
  "fmap_states_ta id 𝒜 = 𝒜"
  by (auto simp: fmap_states_ta_def map_ta_rule_iff prod.map_id0)

lemmas fmap_funs_ta_id' [simp] = fmap_funs_ta_id[unfolded id_def]

lemma fmap_funs_ta_comp:
  "fmap_funs_ta h (fmap_funs_ta k A) = fmap_funs_ta (h ∘ k) A"
proof -
  have "r |∈| rules A ⟹ map_ta_rule id h (map_ta_rule id k r) = map_ta_rule id (λx. h (k x)) r" for r
    by (cases r) (auto)
  then show ?thesis
    by (force simp: fmap_funs_ta_def fimage_iff cong: fmap_funs_ta_cong)
qed

lemma fmap_funs_reg_comp:
  "fmap_funs_reg h (fmap_funs_reg k A) = fmap_funs_reg (h ∘ k) A"
  using fmap_funs_ta_comp unfolding fmap_funs_reg_def
  by auto

lemma fmap_states_ta_comp:
  "fmap_states_ta h (fmap_states_ta k A) = fmap_states_ta (h ∘ k) A"
  by (auto simp: fmap_states_ta_def ta_rule.map_comp comp_def id_def prod.map_comp)

lemma funs_ta_fmap_funs_ta [simp]:
  "funs_ta (fmap_funs_ta f A) = f |`| funs_ta A"
  by (auto simp: funs_ta fmap_funs_ta_def' comp_def fimage_iff
    split!: ta_rule.splits) force+

lemma ta_der_funs_ta:
  "q |∈| ta_der A t ⟹ ffuns_term t |⊆| funs_ta A"
proof (induct t arbitrary: q)
  case (Fun f ts)
  then have "f |∈| funs_ta A" by (auto simp: funs_ta_def)
  then show ?case using Fun(1)[OF nth_mem, THEN fsubsetD] Fun(2)
    by (auto simp: in_fset_conv_nth) blast+
qed auto

lemma ta_der_fmap_funs_ta:
  "q |∈| ta_der A t ⟹ q |∈| ta_der (fmap_funs_ta f A) (map_funs_term f t)"
  by (induct t arbitrary: q) (auto 0 4 simp: fmap_funs_ta_def')

lemma ta_der_fmap_states_ta:
  assumes "q |∈| ta_der A t"
  shows "h q |∈| ta_der (fmap_states_ta h A) (map_vars_term h t)"
proof -
  have [intro]: "(q, q') |∈| (eps A)|+| ⟹ (h q, h q') |∈| (eps (fmap_states_ta h A))|+|" for q q'
    by (force intro!: ftrancl_map[of "eps A"] simp: fmap_states_ta_def)
  show ?thesis using assms
  proof (induct rule: ta_der_induct)
    case (Fun f ts ps p q)
    have "f (map h ps) → h p |∈| rules (fmap_states_ta h A)"
      using Fun(1) by (force simp: fmap_states_ta_def')
    then show ?case using Fun by (auto 0 4)
  qed auto
qed

lemma ta_der_fmap_states_ta_mono:
  shows "f |`| ta_der A (term_of_gterm s) |⊆| ta_der (fmap_states_ta f A) (term_of_gterm s)"
  using ta_der_fmap_states_ta[of _ A "term_of_gterm s" f]
  by (simp add: fimage_fsubsetI ta_der_to_fmap_states_der)

lemma ta_der_fmap_states_ta_mono2:
  assumes "finj_on f (𝒬 A)"
  shows "ta_der (fmap_states_ta f A) (term_of_gterm s) |⊆| f |`| ta_der A (term_of_gterm s)"
  using ta_der_fmap_states_conv[OF assms] by auto

lemma fmap_funs_ta_der':
  "q |∈| ta_der (fmap_funs_ta h A) t ⟹ ∃t'. q |∈| ta_der A t' ∧ map_funs_term h t' = t"
proof (induct rule: ta_der_induct)
  case (Var q v)
  then show ?case by (auto simp: fmap_funs_ta_def intro!: exI[of _ "Var v"])
next
  case (Fun f ts ps p q)
  obtain f' ts' where root: "f = h f'" "f' ps → p |∈| rules A" and
    "⋀i. i < length ts ⟹ ps ! i |∈| ta_der A (ts' i) ∧ map_funs_term h (ts' i) = ts ! i"
    using Fun(1, 5) unfolding fmap_funs_ta_def'
    by auto metis
  note [simp] = conjunct1[OF this(3)] conjunct2[OF this(3), unfolded id_def]
  have [simp]: "p = q ⟹ f' ps → q |∈| rules A" using root(2) by auto
  show ?case using Fun(3)
    by (auto simp: comp_def Fun root fmap_funs_ta_def'
      intro!: exI[of _ "Fun f' (map ts' [0..<length ts])"] exI[of _ ps] exI[of _ p] nth_equalityI)
qed

lemma fmap_funs_gta_lang:
  "gta_lang Q (fmap_funs_ta h 𝒜) = map_gterm h ` gta_lang Q 𝒜" (is "?Ls = ?Rs")
proof -
  {fix s assume "s ∈ ?Ls" then obtain q where
    lang: "q |∈| Q" "q |∈| ta_der (fmap_funs_ta h 𝒜) (term_of_gterm s)"
      by auto
    from fmap_funs_ta_der'[OF this(2)] obtain t where
    t: "q |∈| ta_der 𝒜 t" "map_funs_term h t = term_of_gterm s" "ground t"
      by (metis ground_map_term ground_term_of_gterm)
    then have "s ∈ ?Rs" using map_gterm_of_term[OF t(3), of h id] lang
      by (auto simp: gta_lang_def gta_der_def image_iff)
         (metis fempty_iff finterI ground_term_to_gtermD map_term_of_gterm term_of_gterm_inv)}
  moreover have "?Rs ⊆ ?Ls" using ta_der_fmap_funs_ta[of _ 𝒜 _ h]
    by (auto elim!: gta_langE intro!: gta_langI) fastforce
  ultimately show ?thesis by blast
qed

lemma fmap_funs_ℒ:
  "ℒ (fmap_funs_reg h R) =  map_gterm h ` ℒ R"
  using fmap_funs_gta_lang[of "fin R" h]
  by (auto simp: fmap_funs_reg_def ℒ_def)

lemma ta_states_fmap_funs_ta [simp]: "𝒬 (fmap_funs_ta f A) = 𝒬 A"
  by (auto simp: fmap_funs_ta_def 𝒬_def)
 
lemma ta_reachable_fmap_funs_ta [simp]:
  "ta_reachable (fmap_funs_ta f A) = ta_reachable A" unfolding ta_reachable_def
  by (metis (mono_tags, lifting) fmap_funs_ta_der' ta_der_fmap_funs_ta ground_map_term)


lemma fin_in_states:
  "fin (reg_Restr_Qf R) |⊆| 𝒬r (reg_Restr_Qf R)"
  by (auto simp: reg_Restr_Qf_def)

lemma fmap_states_reg_Restr_Qf_fin:
  "finj_on f (𝒬 𝒜) ⟹ fin (fmap_states_reg f (reg_Restr_Qf R)) |⊆| 𝒬r (fmap_states_reg f (reg_Restr_Qf R))"
  by (auto simp: fmap_states_reg_def reg_Restr_Qf_def)

lemma ℒ_fmap_states_reg_Inl_Inr [simp]:
  "ℒ (fmap_states_reg Inl R) = ℒ R"
  "ℒ (fmap_states_reg Inr R) = ℒ R"
  unfolding ℒ_def fmap_states_reg_def
  by (auto simp: finj_Inl_Inr intro!: fmap_states_ta_lang2)

lemma finite_Collect_prod_ta_rules:
  "finite {f qs → (a, b) |f qs a b. f map fst qs → a |∈| rules 𝒜 ∧ f map snd qs → b |∈| rules 𝔅}" (is "finite ?set")
proof -
  have "?set ⊆ (λ (ra, rb). case ra of f ps → p ⇒ case rb of g qs → q ⇒ f (zip ps qs) → (p, q)) ` (srules 𝒜 × srules 𝔅)"
    by (auto simp: srules_def image_iff fmember.rep_eq split!: ta_rule.splits)
       (metis ta_rule.inject zip_map_fst_snd)
  from finite_imageI[of "srules 𝒜 × srules 𝔅", THEN finite_subset[OF this]]
  show ?thesis by (auto simp: srules_def)
qed

― ‹The product automaton of the automata A and B is constructed
 by applying the rules on pairs of states›

lemmas prod_eps_def = prod_epsLp_def prod_epsRp_def

lemma finite_prod_epsLp:
  "finite (Collect (prod_epsLp 𝒜 ℬ))"
  by (intro finite_subset[of "Collect (prod_epsLp 𝒜 ℬ)" "fset ((𝒬 𝒜 |×| 𝒬 ℬ) |×| 𝒬 𝒜 |×| 𝒬 ℬ)"])
     (auto simp: prod_epsLp_def simp flip: fmember.rep_eq dest: eps_statesD)

lemma finite_prod_epsRp:
  "finite (Collect (prod_epsRp 𝒜 ℬ))"
  by (intro finite_subset[of "Collect (prod_epsRp 𝒜 ℬ)" "fset ((𝒬 𝒜 |×| 𝒬 ℬ) |×| 𝒬 𝒜 |×| 𝒬 ℬ)"])
     (auto simp: prod_epsRp_def simp flip: fmember.rep_eq dest: eps_statesD)
lemmas finite_prod_eps [simp] = finite_prod_epsLp[unfolded prod_epsLp_def] finite_prod_epsRp[unfolded prod_epsRp_def]

lemma [simp]: "f qs → q |∈| rules (prod_ta 𝒜 ℬ) ⟷ f qs → q |∈| prod_ta_rules 𝒜 ℬ"
  "r |∈| rules (prod_ta 𝒜 ℬ) ⟷ r |∈| prod_ta_rules 𝒜 ℬ"
  by (auto simp: prod_ta_def)

lemma prod_ta_states:
  "𝒬 (prod_ta 𝒜 ℬ) |⊆| 𝒬 𝒜 |×| 𝒬 ℬ"
proof -
  {fix q assume "q |∈| rule_states (rules (prod_ta 𝒜 ℬ))"
    then obtain f ps p where "f ps → p |∈| rules (prod_ta 𝒜 ℬ)" and "q |∈| fset_of_list ps ∨ p = q"
      by (metis rule_statesE)
    then have "fst q |∈| 𝒬 𝒜 ∧ snd q |∈| 𝒬 ℬ"
      using rule_statesD(2, 4)[of f "map fst ps" "fst p" 𝒜]
      using rule_statesD(2, 4)[of f "map snd ps" "snd p" ℬ]
      by auto}
  moreover
  {fix q assume "q |∈| eps_states (eps (prod_ta 𝒜 ℬ))" then have "fst q |∈| 𝒬 𝒜 ∧ snd q |∈| 𝒬 ℬ"
      by (auto simp: eps_states_def prod_ta_def prod_eps_def dest: eps_statesD)}
  ultimately show ?thesis
    by (auto simp: 𝒬_def) blast+
qed

lemma prod_ta_det:
  assumes "ta_det 𝒜" and "ta_det ℬ"
  shows "ta_det (prod_ta 𝒜 ℬ)"
  using assms unfolding ta_det_def prod_ta_def prod_eps_def
  by auto

lemma prod_ta_sig:
  "ta_sig (prod_ta 𝒜 ℬ) |⊆| ta_sig 𝒜 |∪| ta_sig ℬ"
  by (auto simp add: ta_sig_def fimage_iff fBall_def)+

lemma from_prod_eps:
  "(p, q) |∈| (eps (prod_ta 𝒜 ℬ))|+| ⟹ (snd p, snd q) |∉| (eps ℬ)|+| ⟹ snd p = snd q ∧ (fst p, fst q) |∈| (eps 𝒜)|+|"
  "(p, q) |∈| (eps (prod_ta 𝒜 ℬ))|+| ⟹ (fst p, fst q) |∉| (eps 𝒜)|+| ⟹ fst p = fst q ∧ (snd p, snd q) |∈| (eps ℬ)|+|"
  apply (induct rule: ftrancl_induct) 
  apply (auto simp: prod_ta_def prod_eps_def intro: ftrancl_into_trancl )
  apply (simp add: fr_into_trancl not_ftrancl_into)+
  done

lemma to_prod_eps𝒜:
  "(p, q) |∈| (eps 𝒜)|+| ⟹ r |∈| 𝒬 ℬ ⟹ ((p, r), (q, r)) |∈| (eps (prod_ta 𝒜 ℬ))|+|"
  by (induct rule: ftrancl_induct)
     (auto simp: prod_ta_def prod_eps_def intro: fr_into_trancl ftrancl_into_trancl)

lemma to_prod_epsℬ:
  "(p, q) |∈| (eps ℬ)|+| ⟹ r |∈| 𝒬 𝒜 ⟹ ((r, p), (r, q)) |∈| (eps (prod_ta 𝒜 ℬ))|+|"
  by (induct rule: ftrancl_induct)
     (auto simp: prod_ta_def prod_eps_def intro: fr_into_trancl ftrancl_into_trancl)

lemma to_prod_eps:
  "(p, q) |∈| (eps 𝒜)|+| ⟹ (p', q') |∈| (eps ℬ)|+| ⟹ ((p, p'), (q, q')) |∈| (eps (prod_ta 𝒜 ℬ))|+|"
proof (induct rule: ftrancl_induct)
  case (Base a b)
  show ?case using Base(2, 1)
  proof (induct rule: ftrancl_induct)
    case (Base c d)
    then have "((a, c), b, c) |∈| (eps (prod_ta 𝒜 ℬ))|+|" using finite_prod_eps
      by (auto simp: prod_ta_def prod_eps_def dest: eps_statesD intro!: fr_into_trancl ftrancl_into_trancl)
    moreover have "((b, c), b, d) |∈| (eps (prod_ta 𝒜 ℬ))|+|" using finite_prod_eps Base
      by (auto simp: prod_ta_def prod_eps_def dest: eps_statesD intro!: fr_into_trancl ftrancl_into_trancl)
    ultimately show ?case
      by (auto intro: ftrancl_trans)
  next
    case (Step p q r)
    then have "((b, q), b, r) |∈| (eps (prod_ta 𝒜 ℬ))|+|" using finite_prod_eps
      by (auto simp: prod_ta_def prod_eps_def dest: eps_statesD intro!: fr_into_trancl)
    then show ?case using Step
      by (auto intro: ftrancl_trans)
  qed
next
  case (Step a b c)
  from Step have "q' |∈| 𝒬 ℬ"
    by (auto dest: eps_trancl_statesD)
  then have "((b, q'), (c,q')) |∈| (eps (prod_ta 𝒜 ℬ))|+|" 
    using Step(3) finite_prod_eps
    by (auto simp: prod_ta_def prod_eps_def intro!: fr_into_trancl)
  then show ?case using ftrancl_trans Step
    by auto
qed

lemma prod_ta_der_to_𝒜_ℬ_der1:
  assumes "q |∈| ta_der (prod_ta 𝒜 ℬ) (term_of_gterm t)"
  shows "fst q |∈| ta_der 𝒜 (term_of_gterm t)" using assms
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  then show ?case
    by (auto dest: from_prod_eps intro!: exI[of _ "map fst ps"] exI[of _ "fst p"])
qed

lemma prod_ta_der_to_𝒜_ℬ_der2:
  assumes "q |∈| ta_der (prod_ta 𝒜 ℬ) (term_of_gterm t)"
  shows  "snd q |∈| ta_der ℬ (term_of_gterm t)" using assms
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  then show ?case
    by (auto dest: from_prod_eps intro!: exI[of _ "map snd ps"] exI[of _ "snd p"])
qed

lemma 𝒜_ℬ_der_to_prod_ta:
  assumes "fst q |∈| ta_der 𝒜 (term_of_gterm t)" "snd q |∈| ta_der ℬ (term_of_gterm t)"
  shows "q |∈| ta_der (prod_ta 𝒜 ℬ) (term_of_gterm t)" using assms
proof (induct t arbitrary: q)
  case (GFun f ts)
  from GFun(2, 3) obtain ps qs p q' where
    rules: "f ps → p |∈| rules 𝒜" "f qs → q' |∈| rules ℬ" "length ps = length ts" "length ps = length qs" and
    eps: "p = fst q ∨ (p, fst q) |∈| (eps 𝒜)|+|" "q' = snd q ∨ (q', snd q) |∈| (eps ℬ)|+|" and
    steps: "∀ i < length qs. ps ! i |∈| ta_der 𝒜 (term_of_gterm (ts ! i))"
      "∀ i < length qs. qs ! i |∈| ta_der ℬ (term_of_gterm (ts ! i))"
    by auto
  from rules have st: "p |∈| 𝒬 𝒜" "q' |∈| 𝒬 ℬ" by (auto dest: rule_statesD)
  have "(p, snd q) = q ∨ ((p, q'), q) |∈| (eps (prod_ta 𝒜 ℬ))|+|" using eps st
    using to_prod_epsℬ[of q' "snd q" ℬ "fst q" 𝒜]
    using to_prod_eps𝒜[of p "fst q" 𝒜 "snd q" ℬ]
    using to_prod_eps[of p "fst q" 𝒜 q' "snd q" ℬ]
    by (cases "p = fst q"; cases "q' = snd q") (auto simp: prod_ta_def)
  then show ?case using rules eps steps GFun(1) st
    by (cases "(p, snd q) = q")
       (auto simp: finite_Collect_prod_ta_rules dest: to_prod_epsℬ intro!: exI[of _ p] exI[of _ q'] exI[of _ "zip ps qs"])
qed

lemma prod_ta_der:
  "q |∈| ta_der (prod_ta 𝒜 ℬ) (term_of_gterm t) ⟷
     fst q |∈| ta_der 𝒜 (term_of_gterm t) ∧ snd q |∈| ta_der ℬ (term_of_gterm t)"
  using prod_ta_der_to_𝒜_ℬ_der1 prod_ta_der_to_𝒜_ℬ_der2 𝒜_ℬ_der_to_prod_ta
  by blast

lemma intersect_ta_gta_lang:
 "gta_lang (Q𝒜 |×| Qℬ) (prod_ta 𝒜 ℬ) = gta_lang Q𝒜 𝒜 ∩ gta_lang Qℬ ℬ"
  by (auto simp: prod_ta_der elim!: gta_langE intro: gta_langI)


lemma ℒ_intersect: "ℒ (reg_intersect R L) = ℒ R ∩ ℒ L"
  by (auto simp: intersect_ta_gta_lang ℒ_def reg_intersect_def)

lemma intersect_ta_ta_lang:
 "ta_lang (Q𝒜 |×| Qℬ) (prod_ta 𝒜 ℬ) = ta_lang Q𝒜 𝒜 ∩ ta_lang Qℬ ℬ"
  using intersect_ta_gta_lang[of Q𝒜 Qℬ 𝒜 ℬ]
  by auto (metis IntI imageI term_of_gterm_inv)

―  ‹Union of tree automata›

lemma ta_union_ta_subset:
  "ta_subset 𝒜 (ta_union 𝒜 ℬ)" "ta_subset ℬ (ta_union 𝒜 ℬ)"
  unfolding ta_subset_def ta_union_def
  by auto

lemma ta_union_states [simp]:
  "𝒬 (ta_union 𝒜 ℬ) = 𝒬 𝒜 |∪| 𝒬 ℬ"
  by (auto simp: ta_union_def 𝒬_def)

lemma ta_union_sig [simp]:
  "ta_sig (ta_union 𝒜 ℬ) = ta_sig 𝒜 |∪| ta_sig ℬ"
  by (auto simp: ta_union_def ta_sig_def)

lemma ta_union_eps_disj_states:
  assumes "𝒬 𝒜 |∩| 𝒬 ℬ = {||}" and "(p, q) |∈| (eps (ta_union 𝒜 ℬ))|+|"
  shows "(p, q) |∈| (eps 𝒜)|+| ∨ (p, q) |∈| (eps ℬ)|+|" using assms(2, 1)
  by (induct rule: ftrancl_induct)
     (auto simp: ta_union_def ftrancl_into_trancl dest: eps_statesD eps_trancl_statesD)

lemma eps_ta_union_eps [simp]:
  "(p, q) |∈| (eps 𝒜)|+| ⟹ (p, q) |∈| (eps (ta_union 𝒜 ℬ))|+|"
  "(p, q) |∈| (eps ℬ)|+| ⟹ (p, q) |∈| (eps (ta_union 𝒜 ℬ))|+|"
  by (auto simp add: in_ftrancl_UnI ta_union_def)


lemma disj_states_eps [simp]:
  "𝒬 𝒜 |∩| 𝒬 ℬ = {||} ⟹ f ps → p |∈| rules 𝒜 ⟹ (p, q) |∈| (eps ℬ)|+| ⟷ False"
  "𝒬 𝒜 |∩| 𝒬 ℬ = {||} ⟹ f ps → p |∈| rules ℬ ⟹ (p, q) |∈| (eps 𝒜)|+| ⟷  False"
  by (auto simp: rtrancl_eq_or_trancl dest: rule_statesD eps_trancl_statesD)

lemma ta_union_der_disj_states:
  assumes "𝒬 𝒜 |∩| 𝒬 ℬ = {||}" and "q |∈| ta_der (ta_union 𝒜 ℬ) t"
  shows "q |∈| ta_der 𝒜 t ∨ q |∈| ta_der ℬ t" using assms(2)
proof (induct rule: ta_der_induct)
  case (Var q v)
  then show ?case using ta_union_eps_disj_states[OF assms(1)]
    by auto
next
  case (Fun f ts ps p q)
  have dist: "fset_of_list ps |⊆| 𝒬 𝒜 ⟹ i < length ts ⟹ ps ! i |∈| ta_der 𝒜 (ts ! i)"
    "fset_of_list ps |⊆| 𝒬 ℬ ⟹ i < length ts ⟹ ps ! i |∈| ta_der ℬ (ts ! i)" for i
    using Fun(2) Fun(5)[of i] assms(1)
    by (auto dest!: ta_der_not_stateD fsubsetD)
  from Fun(1) consider (a) "fset_of_list ps |⊆| 𝒬 𝒜" | (b) "fset_of_list ps |⊆| 𝒬 ℬ"
    by (auto simp: ta_union_def dest: rule_statesD)
  then show ?case using dist Fun(1, 2) assms(1) ta_union_eps_disj_states[OF assms(1), of p q] Fun(3)
    by (cases) (auto simp: fsubsetI rule_statesD ta_union_def intro!: exI[of _ p] exI[of _ ps])   
qed

lemma ta_union_der_disj_states':
  assumes "𝒬 𝒜 |∩| 𝒬 ℬ = {||}"
  shows "ta_der (ta_union 𝒜 ℬ) t = ta_der 𝒜 t |∪| ta_der ℬ t"
  using ta_union_der_disj_states[OF assms] ta_der_mono' ta_union_ta_subset
  by (auto, fastforce) blast

lemma ta_union_gta_lang:
  assumes "𝒬 𝒜 |∩| 𝒬 ℬ = {||}" and "Q𝒜 |⊆| 𝒬 𝒜" and "Qℬ |⊆| 𝒬 ℬ"
  shows"gta_lang (Q𝒜 |∪| Qℬ) (ta_union 𝒜 ℬ) = gta_lang Q𝒜 𝒜 ∪ gta_lang Qℬ ℬ" (is "?Ls = ?Rs")
proof -
  {fix s assume "s ∈ ?Ls" then obtain q
      where w: "q |∈| Q𝒜 |∪| Qℬ" "q |∈| ta_der (ta_union 𝒜 ℬ) (term_of_gterm s)"
      by (auto elim: gta_langE)
    from ta_union_der_disj_states[OF assms(1) w(2)] consider
      (a)  "q |∈| ta_der 𝒜 (term_of_gterm s)" | "q |∈| ta_der ℬ (term_of_gterm s)" by blast
    then have "s ∈ ?Rs" using w(1) assms
      by (cases, auto simp: gta_langI)
         (metis fempty_iff finterI funion_iff gterm_ta_der_states sup.orderE)}
  moreover have "?Rs ⊆ ?Ls" using ta_union_der_disj_states'[OF assms(1)]
    by (auto elim!: gta_langE intro!: gta_langI)
  ultimately show ?thesis by blast
qed


lemma ℒ_union: "ℒ (reg_union R L) = ℒ R ∪ ℒ L"
proof -
  let ?inl = "Inl :: 'b ⇒ 'b + 'c" let ?inr = "Inr :: 'c ⇒ 'b + 'c"
  let ?fr = "?inl |`| (fin R |∩| 𝒬r R)" let ?fl = "?inr |`| (fin L |∩| 𝒬r L)"
  have [simp]:"gta_lang (?fr |∪| ?fl) (ta_union (fmap_states_ta ?inl (ta R)) (fmap_states_ta ?inr (ta L))) =
   gta_lang ?fr (fmap_states_ta ?inl (ta R)) ∪ gta_lang ?fl (fmap_states_ta ?inr (ta L))"
    by (intro ta_union_gta_lang) (auto simp: fimage_iff)
  have [simp]: "gta_lang ?fr (fmap_states_ta ?inl (ta R)) = gta_lang (fin R |∩| 𝒬r R) (ta R)"
    by (intro fmap_states_ta_lang) (auto simp: finj_Inl_Inr)
  have [simp]: "gta_lang ?fl (fmap_states_ta ?inr (ta L)) = gta_lang (fin L |∩| 𝒬r L) (ta L)"
    by (intro fmap_states_ta_lang) (auto simp: finj_Inl_Inr)
  show ?thesis
    using gta_lang_Rest_states_conv
    by (auto simp: ℒ_def reg_union_def ta_union_gta_lang) fastforce
qed

lemma reg_union_states:
  "𝒬r (reg_union A B) = (Inl |`| 𝒬r A) |∪| (Inr |`| 𝒬r B)"
  by (auto simp: reg_union_def)

― ‹Deciding emptiness›

lemma ta_empty [simp]:
  "ta_empty Q 𝒜 = (gta_lang Q 𝒜 = {})"
  by (auto simp: ta_empty_def elim!: gta_langE ta_reachable_gtermE
    intro: ta_reachable_gtermI gta_langI)


lemma reg_empty [simp]:
  "reg_empty R = (ℒ R = {})"
  by (simp add: ℒ_def reg_empty_def)

text ‹Epsilon free automaton›

lemma finite_eps_free_rulep [simp]:
  "finite (Collect (eps_free_rulep 𝒜))"
proof -
  let ?par = "(λ r. case r of f qs → q ⇒ (f, qs)) |`| (rules 𝒜)"
  let ?st = "(λ (r, q). case r of (f, qs) ⇒ TA_rule f qs q) |`| (?par |×| 𝒬 𝒜)"
  show ?thesis using rule_statesD eps_trancl_statesD
    by (intro finite_subset[of "Collect (eps_free_rulep 𝒜)" "fset ?st"])
       (auto simp: eps_free_rulep_def fimage_iff
             simp flip: fset.set_map fmember.rep_eq
             split!: ta_rule.splits, fastforce+)
qed

lemmas finite_eps_free_rule [simp] = finite_eps_free_rulep[unfolded eps_free_rulep_def]

lemma ta_res_eps_free:
  "ta_der (eps_free 𝒜) (term_of_gterm t) = ta_der 𝒜 (term_of_gterm t)" (is "?Ls = ?Rs")
proof -
  {fix q assume "q |∈| ?Ls" then have "q |∈| ?Rs"
      by (induct rule: ta_der_gterm_induct)
         (auto simp: eps_free_def eps_free_rulep_def)}
  moreover
  {fix q assume "q |∈| ?Rs" then have "q |∈| ?Ls"
    proof (induct rule: ta_der_gterm_induct)
      case (GFun f ts ps p q)
      then show ?case
        by (auto simp: eps_free_def eps_free_rulep_def intro!: exI[of _ ps])
    qed}
  ultimately show ?thesis by blast
qed

lemma ta_lang_eps_free [simp]:
  "gta_lang Q (eps_free 𝒜) = gta_lang Q 𝒜"
  by (auto simp add: ta_res_eps_free elim!: gta_langE intro: gta_langI)

lemma ℒ_eps_free: "ℒ (eps_free_reg R) = ℒ R"
  by (auto simp: ℒ_def eps_free_reg_def)

text ‹Sufficient criterion for containment›
  (* sufficient criterion to check whether automaton accepts at least T_g(F) where F is a subset of
   the signature *) 

definition ta_contains_aux :: "('f × nat) set ⇒ 'q fset ⇒ ('q, 'f) ta ⇒ 'q fset ⇒ bool" where
  "ta_contains_aux ℱ Q1 𝒜 Q2 ≡ (∀ f qs. (f, length qs) ∈ ℱ ∧ fset_of_list qs |⊆| Q1 ⟶
     (∃ q q'. TA_rule f qs q |∈| rules 𝒜 ∧ q' |∈| Q2 ∧ (q = q' ∨ (q, q') |∈| (eps 𝒜)|+|)))"

lemma ta_contains_aux_state_set:
  assumes "ta_contains_aux ℱ Q 𝒜 Q" "t ∈ 𝒯G ℱ"
  shows "∃ q. q |∈| Q ∧ q |∈| ta_der 𝒜 (term_of_gterm t)" using assms(2)
proof (induct rule: 𝒯G.induct)
  case (const a)
  then show ?case using assms(1)
    by (force simp: ta_contains_aux_def)
next
  case (ind f n ss)
  obtain qs where "fset_of_list qs |⊆| Q" "length ss = length qs"
    "∀ i < length qs. qs ! i |∈| ta_der 𝒜 (term_of_gterm (ss ! i))"
    using ind(4) Ex_list_of_length_P[of "length ss" "λ q i. q |∈| Q ∧ q |∈| ta_der 𝒜 (term_of_gterm (ss ! i))"]
    by (auto simp: fset_list_fsubset_eq_nth_conv) metis
  then show ?case using ind(1 - 3) assms(1)
    by (auto simp: ta_contains_aux_def) blast
qed

lemma ta_contains_aux_mono:
  assumes "ta_subset 𝒜 ℬ" and "Q2 |⊆| Q2'"
  shows "ta_contains_aux ℱ Q1 𝒜 Q2 ⟹ ta_contains_aux ℱ Q1 ℬ Q2'"
  using assms unfolding ta_contains_aux_def ta_subset_def
  by (meson fin_mono ftrancl_mono)
 
definition ta_contains :: "('f × nat) set ⇒ ('f × nat) set ⇒ ('q, 'f) ta ⇒ 'q fset ⇒ 'q fset ⇒ bool"
  where "ta_contains ℱ 𝒢 𝒜 Q Qf ≡ ta_contains_aux ℱ Q 𝒜 Q ∧ ta_contains_aux 𝒢 Q 𝒜 Qf"

lemma ta_contains_mono:
  assumes "ta_subset 𝒜 ℬ" and "Qf |⊆| Qf'"
  shows "ta_contains ℱ 𝒢 𝒜 Q Qf ⟹ ta_contains ℱ 𝒢 ℬ Q Qf'"
  unfolding ta_contains_def 
  using ta_contains_aux_mono[OF assms(1) fsubset_refl]
  using ta_contains_aux_mono[OF assms]
  by blast

lemma ta_contains_both: 
  assumes contain: "ta_contains ℱ 𝒢 𝒜 Q Qf"
  shows "⋀ t. groot t ∈ 𝒢 ⟹ ⋃ (funas_gterm ` set (gargs t)) ⊆ ℱ ⟹ t ∈ gta_lang Qf 𝒜"
proof -
  fix t :: "'a gterm"
  assume F: "⋃ (funas_gterm ` set (gargs t)) ⊆ ℱ" and G: "groot t ∈ 𝒢"
  obtain g ss where t[simp]: "t = GFun g ss" by (cases t, auto)
  then have "∃ qs. length qs = length ss ∧ (∀ i < length qs. qs ! i |∈| ta_der 𝒜 (term_of_gterm (ss ! i)) ∧ qs ! i |∈| Q)"
    using contain ta_contains_aux_state_set[of ℱ Q 𝒜 "ss ! i" for i] F
    unfolding ta_contains_def 𝒯G_funas_gterm_conv
    using Ex_list_of_length_P[of "length ss" "λ q i. q |∈| Q ∧ q |∈| ta_der 𝒜 (term_of_gterm (ss ! i))"]
    by auto (metis SUP_le_iff nth_mem)
  then obtain qs where " length qs = length ss"
    "∀ i < length qs. qs ! i |∈| ta_der 𝒜 (term_of_gterm (ss ! i))"
    "∀ i < length qs. qs ! i |∈| Q"
    by blast
  then obtain q where "q |∈| Qf" "q |∈| ta_der 𝒜 (term_of_gterm t)"
    using conjunct2[OF contain[unfolded ta_contains_def]] G
    by (auto simp: ta_contains_def ta_contains_aux_def fset_list_fsubset_eq_nth_conv) metis
  then show "t ∈ gta_lang Qf 𝒜"
    by (intro gta_langI) simp
qed

lemma ta_contains: 
  assumes contain: "ta_contains ℱ ℱ 𝒜 Q Qf"
  shows "𝒯G ℱ ⊆ gta_lang Qf 𝒜" (is "?A ⊆ _")
proof -
  have [simp]: "funas_gterm t ⊆ ℱ ⟹ groot t ∈ ℱ" for t by (cases t) auto
  have [simp]: "funas_gterm t ⊆ ℱ ⟹ ⋃ (funas_gterm ` set (gargs t)) ⊆ ℱ" for t
    by (cases t) auto
  show ?thesis using ta_contains_both[OF contain]
    by (auto simp: 𝒯G_equivalent_def)
qed

text ‹Relabeling, map finite set to natural numbers›


lemma map_fset_to_nat_inj:
  assumes "Y |⊆| X"
  shows "finj_on (map_fset_to_nat X) Y"
proof -
  { fix x y assume "x |∈| X" "y |∈| X"
    then have "x |∈| fset_of_list (sorted_list_of_fset X)" "y |∈| fset_of_list (sorted_list_of_fset X)"
      by simp_all
    note this[unfolded mem_idx_fset_sound]
    then have "x = y" if "map_fset_to_nat X x = map_fset_to_nat X y"
      using that nth_eq_iff_index_eq[OF distinct_sorted_list_of_fset[of X]]
      by (force dest: mem_idx_sound_output simp: map_fset_to_nat_def) }
  then show ?thesis using assms
    by (auto simp add: finj_on_def' fBall_def)
qed

lemma map_fset_fset_to_nat_inj:
  assumes "Y |⊆| X"
  shows "finj_on (map_fset_fset_to_nat X) Y" using assms
proof -
  let ?f = "map_fset_fset_to_nat X"
  { fix x y assume "x |∈| X" "y |∈| X"
    then have "sorted_list_of_fset x |∈| fset_of_list (sorted_list_of_fset (sorted_list_of_fset |`| X))"
      "sorted_list_of_fset y |∈| fset_of_list (sorted_list_of_fset (sorted_list_of_fset |`| X))"
        unfolding map_fset_fset_to_nat_def by auto
    note this[unfolded mem_idx_fset_sound]
    then have "x = y" if "?f x = ?f y"
      using that nth_eq_iff_index_eq[OF distinct_sorted_list_of_fset[of "sorted_list_of_fset |`| X"]]
      by (auto simp: map_fset_fset_to_nat_def)
         (metis mem_idx_sound_output notin_fset sorted_list_of_fset_simps(1))+}
  then show ?thesis using assms
    by (auto simp add: finj_on_def' fBall_def)
qed


lemma relabel_gta_lang [simp]:
  "gta_lang (relabel_Qf Q 𝒜) (relabel_ta 𝒜) = gta_lang Q 𝒜"
proof -
  have "gta_lang (relabel_Qf Q 𝒜) (relabel_ta 𝒜) = gta_lang (Q |∩| 𝒬 𝒜) 𝒜"
    unfolding relabel_ta_def relabel_Qf_def
    by (intro fmap_states_ta_lang2 map_fset_to_nat_inj) simp
  then show ?thesis by fastforce
qed


lemma ℒ_relable [simp]: "ℒ (relabel_reg R) = ℒ R"
  by (auto simp: ℒ_def relabel_reg_def)

lemma relabel_ta_lang [simp]:
  "ta_lang (relabel_Qf Q 𝒜) (relabel_ta 𝒜) = ta_lang Q 𝒜"
  unfolding ta_lang_to_gta_lang
  using relabel_gta_lang
  by simp



lemma relabel_fset_gta_lang [simp]:
  "gta_lang (relabel_fset_Qf Q 𝒜) (relabel_fset_ta 𝒜) = gta_lang Q 𝒜"
proof -
  have "gta_lang (relabel_fset_Qf Q 𝒜) (relabel_fset_ta 𝒜) = gta_lang (Q |∩| 𝒬 𝒜) 𝒜"
    unfolding relabel_fset_Qf_def relabel_fset_ta_def
    by (intro fmap_states_ta_lang2 map_fset_fset_to_nat_inj) simp
  then show ?thesis by fastforce
qed


lemma ℒ_relable_fset [simp]: "ℒ (relable_fset_reg R) = ℒ R"
  by (auto simp: ℒ_def relable_fset_reg_def)

lemma ta_states_trim_ta:
  "𝒬 (trim_ta Q 𝒜) |⊆| 𝒬 𝒜"
  unfolding trim_ta_def using ta_prod_reach_states .

lemma trim_ta_reach: "𝒬 (trim_ta Q 𝒜) |⊆| ta_reachable (trim_ta Q 𝒜)"
  unfolding trim_ta_def using ta_only_prod_reachable ta_only_reach_reachable
  by metis

lemma trim_ta_prod: "𝒬 (trim_ta Q A) |⊆| ta_productive Q (trim_ta Q A)"
  unfolding trim_ta_def using ta_only_prod_productive
  by metis

lemma empty_gta_lang:
  "gta_lang Q (TA {||} {||}) = {}"
  using ta_reachable_gtermI
  by (force simp: gta_lang_def gta_der_def elim!: ta_langE)

abbreviation empty_reg where
  "empty_reg ≡ Reg {||} (TA {||} {||})"

lemma ℒ_epmty:
  "ℒ empty_reg = {}"
  by (auto simp: ℒ_def empty_gta_lang)

lemma const_ta_lang:
  "gta_lang {|q|} (TA  {| TA_rule f [] q |} {||}) = {GFun f []}"
proof -
  have [dest!]: "q' |∈| ta_der (TA  {| TA_rule f [] q |} {||}) t' ⟹ ground t' ⟹ t' = Fun f []" for t' q'
    by (induct t') auto
  show ?thesis
    by (auto simp: gta_lang_def gta_der_def elim!: gta_langE)
       (metis gterm_of_term.simps list.simps(8) term_of_gterm_inv)
qed


lemma run_argsD:
  "run 𝒜 s t ⟹ length (gargs s) = length (gargs t) ∧ (∀ i < length (gargs t). run 𝒜 (gargs s ! i) (gargs t ! i))"
  using run.cases by fastforce

lemma run_root_rule:
  "run 𝒜 s t ⟹ TA_rule (groot_sym t) (map ex_comp_state (gargs s)) (ex_rule_state s) |∈| (rules 𝒜) ∧
     (ex_rule_state s = ex_comp_state s ∨ (ex_rule_state s, ex_comp_state s) |∈| (eps 𝒜)|+|)"
  by (cases s; cases t) (auto elim: run.cases)

lemma run_poss_eq: "run 𝒜 s t ⟹ gposs s = gposs t"
  by (induct rule: run.induct) auto

lemma run_gsubt_cl:
  assumes "run 𝒜 s t" and "p ∈ gposs t"
  shows "run 𝒜 (gsubt_at s p) (gsubt_at t p)" using assms
proof (induct p arbitrary: s t)
  case (Cons i p) show ?case using Cons(1) Cons(2-)
    by (cases s; cases t) (auto dest: run_argsD)
qed auto

lemma run_replace_at:
  assumes "run 𝒜 s t" and "run 𝒜 u v" and "p ∈ gposs s"
    and "ex_comp_state (gsubt_at s p) = ex_comp_state u"
  shows "run 𝒜 s[p ← u]G t[p ← v]G" using assms
proof (induct p arbitrary: s t)
  case (Cons i p)
  obtain r q qs f ts where [simp]: "s = GFun (r, q) qs" "t = GFun f ts" by (cases s, cases t) auto
  have *: "j < length qs ⟹ ex_comp_state (qs[i := (qs ! i)[p ← u]G] ! j) = ex_comp_state (qs ! j)" for j
    using Cons(5) by (cases "i = j", cases p) auto
  have [simp]: "map ex_comp_state (qs[i := (qs ! i)[p ← u]G]) = map ex_comp_state qs" using Cons(5)
    by (auto simp: *[unfolded comp_def] intro!: nth_equalityI)
  have "run 𝒜 (qs ! i)[p ← u]G (ts ! i)[p ← v]G" using Cons(2-)
    by (intro Cons(1)) (auto dest: run_argsD)
  moreover have "i < length qs" "i < length ts" using Cons(4) run_poss_eq[OF Cons(2)]
    by force+
  ultimately show ?case using Cons(2) run_root_rule[OF Cons(2)]
    by (fastforce simp: nth_list_update dest: run_argsD intro!: run.intros)
qed simp

text ‹relating runs to derivation definition›

lemma run_to_comp_st_gta_der:
  "run 𝒜 s t ⟹ ex_comp_state s |∈| gta_der 𝒜 t"
proof (induct s arbitrary: t)
  case (GFun q qs)
  show ?case using GFun(1)[OF nth_mem, of i "gargs t ! i" for i]
    using run_argsD[OF GFun(2)] run_root_rule[OF GFun(2-)]
    by (cases t) (auto simp: gta_der_def intro!: exI[of _ "map ex_comp_state qs"] exI[of _ "fst q"])
qed

lemma run_to_rule_st_gta_der:
  assumes "run 𝒜 s t" shows "ex_rule_state s |∈| gta_der 𝒜 t"
proof (cases s)
  case [simp]: (GFun q qs)
  have "i < length qs ⟹ ex_comp_state (qs ! i) |∈| gta_der 𝒜 (gargs t ! i)" for i
    using run_to_comp_st_gta_der[of 𝒜] run_argsD[OF assms] by force
  then show ?thesis using conjunct1[OF run_argsD[OF assms]] run_root_rule[OF assms]
    by (cases t) (auto simp: gta_der_def intro!: exI[of _ "map ex_comp_state qs"] exI[of _ "fst q"])
qed

lemma run_to_gta_der_gsubt_at:
  assumes "run 𝒜 s t" and "p ∈ gposs t"
  shows "ex_rule_state (gsubt_at s p) |∈| gta_der 𝒜 (gsubt_at t p)"
    "ex_comp_state (gsubt_at s p) |∈| gta_der 𝒜 (gsubt_at t p)"
  using assms run_gsubt_cl[THEN run_to_comp_st_gta_der] run_gsubt_cl[THEN run_to_rule_st_gta_der]
  by blast+

lemma gta_der_to_run:
  "q |∈| gta_der 𝒜 t ⟹ (∃ p qs. run 𝒜 (GFun (p, q) qs) t)" unfolding gta_der_def
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  from GFun(5) Ex_list_of_length_P[of "length ts" "λ qs i. run 𝒜 (GFun (fst qs, ps ! i) (snd qs)) (ts ! i)"]
  obtain qss where mid: "length qss = length ts" "∀ i < length ts .run 𝒜 (GFun (fst (qss ! i), ps ! i) (snd (qss ! i))) (ts ! i)"
    by auto
  have [simp]: "map (ex_comp_state ∘ (λ(qs, y). GFun (fst y, qs) (snd y))) (zip ps qss) = ps" using GFun(2) mid(1)
    by (intro nth_equalityI) auto
  show ?case using mid GFun(1 - 4)
    by (intro exI[of _ p] exI[of _ "map2 (λ f args. GFun (fst args, f) (snd args)) ps qss"])
       (auto intro: run.intros)
qed

lemma run_ta_der_ctxt_split1:
  assumes "run 𝒜 s t" "p ∈ gposs t"
  shows "ex_comp_state s |∈| ta_der 𝒜 (ctxt_at_pos (term_of_gterm t) p)⟨Var (ex_comp_state (gsubt_at s p))⟩"
  using assms
proof (induct p arbitrary: s t)
  case (Cons i p)
  obtain q f qs ts where [simp]: "s = GFun q qs" "t = GFun f ts" and l: "length qs = length ts"
    using run_argsD[OF Cons(2)] by (cases s, cases t) auto
  from Cons(2, 3) l have "ex_comp_state (qs ! i) |∈| ta_der 𝒜 (ctxt_at_pos (term_of_gterm (ts ! i)) p)⟨Var (ex_comp_state (gsubt_at (qs ! i) p))⟩"
    by (intro Cons(1)) (auto dest: run_argsD)
  then show ?case using Cons(2-) l
    by (fastforce simp: nth_append_Cons min_def dest: run_root_rule run_argsD
    intro!: exI[of _ "map ex_comp_state (gargs s)"]  exI[of _ "ex_rule_state s"]
            run_to_comp_st_gta_der[of 𝒜 "qs ! i" "ts ! i" for i, unfolded comp_def gta_der_def])
qed auto


lemma run_ta_der_ctxt_split2:
  assumes "run 𝒜 s t" "p ∈ gposs t"
  shows "ex_comp_state s |∈| ta_der 𝒜 (ctxt_at_pos (term_of_gterm t) p)⟨Var (ex_rule_state (gsubt_at s p))⟩"
proof (cases "ex_rule_state (gsubt_at s p) = ex_comp_state (gsubt_at s p)")
  case False then show ?thesis
    using run_root_rule[OF run_gsubt_cl[OF assms]]
    by (intro ta_der_eps_ctxt[OF run_ta_der_ctxt_split1[OF assms]]) auto
qed (auto simp: run_ta_der_ctxt_split1[OF assms, unfolded comp_def])

end

Theory Tree_Automata_Det

theory Tree_Automata_Det
imports         
  Tree_Automata
begin

subsection ‹Powerset Construction for Tree Automata›

text ‹
The idea to treat states and transitions separately is from arXiv:1511.03595. Some parts of
the implementation are also based on that paper. (The Algorithm corresponds roughly to the one
in "Step 5")
›

text ‹Abstract Definitions and Correctness Proof›

definition ps_reachable_statesp where
  "ps_reachable_statesp 𝒜 f ps = (λ q'. ∃ qs q. TA_rule f qs q |∈| rules 𝒜 ∧ list_all2 (|∈|) qs ps ∧
    (q = q' ∨ (q,q') |∈| (eps 𝒜)|+|))"

lemma ps_reachable_statespE:
  assumes "ps_reachable_statesp 𝒜 f qs q"
  obtains ps p where "TA_rule f ps p |∈| rules 𝒜" "list_all2 (|∈|) ps qs" "(p = q ∨ (p, q) |∈| (eps 𝒜)|+|)"
  using assms unfolding ps_reachable_statesp_def
  by auto

lemma ps_reachable_statesp_𝒬:
  "ps_reachable_statesp 𝒜 f ps q ⟹ q |∈| 𝒬 𝒜"
  by (auto simp: ps_reachable_statesp_def simp flip: fmember.rep_eq dest: rule_statesD eps_trancl_statesD)

lemma finite_Collect_ps_statep [simp]:
  "finite (Collect (ps_reachable_statesp 𝒜 f ps))" (is "finite ?S")
  by (intro finite_subset[of ?S "fset (𝒬 𝒜)"])
     (auto simp: ps_reachable_statesp_𝒬 simp flip: fmember.rep_eq)
lemmas finite_Collect_ps_statep_unfolded [simp] = finite_Collect_ps_statep[unfolded ps_reachable_statesp_def, simplified]

definition "ps_reachable_states 𝒜 f ps ≡ fCollect (ps_reachable_statesp 𝒜 f ps)"

lemmas ps_reachable_states_simp = ps_reachable_statesp_def ps_reachable_states_def

lemma ps_reachable_states_fmember:
  "q' |∈| ps_reachable_states 𝒜 f ps ⟷ (∃ qs q. TA_rule f qs q |∈| rules 𝒜 ∧
     list_all2 (|∈|) qs ps ∧ (q = q' ∨ (q, q') |∈| (eps 𝒜)|+|))"
  by (auto simp: ps_reachable_states_simp)

lemma ps_reachable_statesI:
  assumes "TA_rule f ps p |∈| rules 𝒜" "list_all2 (|∈|) ps qs" "(p = q ∨ (p, q) |∈| (eps 𝒜)|+|)"
  shows "p |∈| ps_reachable_states 𝒜 f qs"
  using assms unfolding ps_reachable_states_simp
  by auto

lemma ps_reachable_states_sig:
  "ps_reachable_states 𝒜 f ps ≠ {||} ⟹ (f, length ps) |∈| ta_sig 𝒜"
  by (auto simp: ps_reachable_states_simp ta_sig_def fimage_iff fBex_def dest!: list_all2_lengthD)

text ‹
A set of "powerset states" is complete if it is sufficient to capture all (non)deterministic
derivations.
›

definition ps_states_complete_it :: "('a, 'b) ta ⇒ 'a FSet_Lex_Wrapper fset ⇒ 'a FSet_Lex_Wrapper fset ⇒ bool"
  where "ps_states_complete_it 𝒜 Q Qnext ≡
  ∀f ps. fset_of_list ps |⊆| Q ∧ ps_reachable_states 𝒜 f (map ex ps) ≠ {||} ⟶ Wrapp (ps_reachable_states 𝒜 f (map ex ps)) |∈| Qnext"

lemma ps_states_complete_itD:
  "ps_states_complete_it 𝒜 Q Qnext ⟹ fset_of_list ps |⊆| Q ⟹
     ps_reachable_states 𝒜 f (map ex ps) ≠ {||} ⟹ Wrapp (ps_reachable_states 𝒜 f (map ex ps)) |∈| Qnext"
  unfolding ps_states_complete_it_def by blast

abbreviation "ps_states_complete 𝒜 Q ≡ ps_states_complete_it 𝒜 Q Q"

text ‹The least complete set of states›
inductive_set ps_states_set for 𝒜 where
  "∀ p ∈ set ps. p ∈ ps_states_set 𝒜 ⟹ ps_reachable_states 𝒜 f (map ex ps) ≠ {||} ⟹
    Wrapp (ps_reachable_states 𝒜 f (map ex ps)) ∈ ps_states_set 𝒜"

lemma ps_states_Pow:
  "ps_states_set 𝒜 ⊆ fset (Wrapp |`| fPow (𝒬 𝒜))"
proof -
  {fix q assume "q ∈ ps_states_set 𝒜" then have "q ∈ fset (Wrapp |`| fPow (𝒬 𝒜))"
      by induct (auto simp: ps_reachable_statesp_𝒬 ps_reachable_states_def image_iff simp flip: fmember.rep_eq)}
  then show ?thesis by blast
qed

context
includes fset.lifting
begin
lift_definition ps_states  :: "('a, 'b) ta ⇒ 'a FSet_Lex_Wrapper fset" is ps_states_set
  by (auto intro: finite_subset[OF ps_states_Pow])

lemma ps_states: "ps_states 𝒜 |⊆| Wrapp |`| fPow (𝒬 𝒜)" using ps_states_Pow
  by (simp add: ps_states_Pow less_eq_fset.rep_eq ps_states.rep_eq)

lemmas ps_states_cases = ps_states_set.cases[Transfer.transferred]
lemmas ps_states_induct = ps_states_set.induct[Transfer.transferred]
lemmas ps_states_simps = ps_states_set.simps[Transfer.transferred]
lemmas ps_states_intros= ps_states_set.intros[Transfer.transferred]
end

lemma ps_states_complete:
  "ps_states_complete 𝒜 (ps_states 𝒜)"
  unfolding ps_states_complete_it_def
  by (auto intro: ps_states_intros)

lemma ps_states_least_complete:
  assumes "ps_states_complete_it 𝒜 Q Qnext" "Qnext |⊆| Q"
    shows "ps_states 𝒜 |⊆| Q"
proof standard
  fix q assume ass: "q |∈| ps_states 𝒜" then show "q |∈| Q"
    using ps_states_complete_itD[OF assms(1)] fsubsetD[OF assms(2)]
    by (induct rule: ps_states_induct[of _ 𝒜]) (fastforce intro: ass)+
qed

definition ps_rulesp :: "('a, 'b) ta ⇒ 'a FSet_Lex_Wrapper fset ⇒ ('a FSet_Lex_Wrapper, 'b) ta_rule ⇒ bool" where
  "ps_rulesp 𝒜 Q = (λ r. ∃ f ps p. r = TA_rule f ps (Wrapp p) ∧ fset_of_list ps |⊆| Q ∧
     p = ps_reachable_states 𝒜 f (map ex ps) ∧ p ≠ {||})"

definition "ps_rules" where
  "ps_rules 𝒜 Q ≡ fCollect (ps_rulesp 𝒜 Q)"

lemma finite_ps_rulesp [simp]:
  "finite (Collect (ps_rulesp 𝒜 Q))" (is "finite ?S")
proof -
  let ?Q = "fset (Wrapp |`| fPow (𝒬 𝒜) |∪| Q)" let ?sig = "fset (ta_sig 𝒜)"
  define args where "args ≡ ⋃ (f,n) ∈ ?sig. {qs| qs. set qs ⊆ ?Q ∧ length qs = n}"
  define bound where "bound ≡ ⋃(f,_) ∈ ?sig. ⋃q ∈ ?Q. ⋃qs ∈ args. {TA_rule f qs q}"
  have finite: "finite ?Q" "finite ?sig" by (auto intro: finite_subset)
  then have "finite args" using finite_lists_length_eq[OF ‹finite ?Q›]
    by (force simp: args_def)
  with finite have "finite bound" unfolding bound_def by (auto simp only: finite_UN)
  moreover have "Collect (ps_rulesp 𝒜 Q) ⊆ bound"
  proof standard
    fix r assume *: "r ∈ Collect (ps_rulesp 𝒜 Q)"
    obtain f ps p where r[simp]: "r = TA_rule f ps p" by (cases r)
    from * obtain qs q where "TA_rule f qs q |∈| rules 𝒜" and len: "length ps = length qs"
      unfolding ps_rulesp_def ps_reachable_states_simp
      using list_all2_lengthD by fastforce 
    from this have sym: "(f, length qs) ∈ ?sig"
      by (auto simp flip: fmember.rep_eq)
    moreover from * have "set ps ⊆ ?Q" unfolding ps_rulesp_def
      by (auto simp flip: fset_of_list_elem fmember.rep_eq simp: ps_reachable_statesp_def)
    ultimately have ps: "ps ∈ args"
      by (auto simp only: args_def UN_iff intro!: bexI[of _ "(f, length qs)"] len)  
    from * have "p ∈ ?Q" unfolding ps_rulesp_def ps_reachable_states_def
      using fmember.rep_eq ps_reachable_statesp_𝒬
      by (fastforce simp add: image_iff)
    with ps sym show "r ∈ bound"
      by (auto simp only: r bound_def UN_iff intro!: bexI[of _ "(f, length qs)"] bexI[of _ "p"] bexI[of _ "ps"])
  qed
  ultimately show ?thesis by (blast intro: finite_subset)
qed

lemmas finite_ps_rulesp_unfolded = finite_ps_rulesp[unfolded ps_rulesp_def, simplified]

lemmas ps_rulesI [intro!] = fCollect_memberI[OF finite_ps_rulesp]

lemma ps_rules_states:
  "rule_states (fCollect (ps_rulesp 𝒜 Q)) |⊆| (Wrapp |`| fPow (𝒬 𝒜) |∪| Q)"
  by (auto simp: ps_rulesp_def rule_states_def ps_reachable_states_def ps_reachable_statesp_𝒬) blast

definition ps_ta :: "('q, 'f) ta ⇒ ('q FSet_Lex_Wrapper, 'f) ta" where
  "ps_ta 𝒜 = (let Q = ps_states 𝒜 in
    TA (ps_rules 𝒜 Q) {||})"

definition ps_ta_Qf :: "'q fset ⇒ ('q, 'f) ta ⇒ 'q FSet_Lex_Wrapper fset" where
  "ps_ta_Qf Q 𝒜 = (let Q' = ps_states 𝒜 in
    ffilter (λ S. Q |∩| (ex S) ≠ {||}) Q')"

lemma ps_rules_sound:
  assumes "p |∈| ta_der (ps_ta 𝒜) (term_of_gterm t)"
  shows "ex p |⊆| ta_der 𝒜 (term_of_gterm t)" using assms
proof (induction rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  then have IH: "∀i < length ts. ex (ps ! i) |⊆| gta_der 𝒜 (ts ! i)" unfolding gta_der_def by auto
  show ?case
  proof standard
    fix r assume "r |∈| ex q"
    with GFun(1 - 3) obtain qs q' where "TA_rule f qs q' |∈| rules 𝒜"
      "q' = r ∨ (q', r) |∈| (eps 𝒜)|+|" "list_all2 (|∈|) qs (map ex ps)" 
      by (auto simp: Let_def ps_ta_def ps_rulesp_def ps_reachable_states_simp ps_rules_def)
    then show "r |∈| ta_der 𝒜 (term_of_gterm (GFun f ts))"
      using GFun(2) IH unfolding gta_der_def
      by (force dest!: fsubsetD intro!: exI[of _ q'] exI[of _ qs] simp: list_all2_conv_all_nth)
  qed
qed

lemma ps_ta_nt_empty_set:
  "TA_rule f qs (Wrapp {||}) |∈| rules (ps_ta 𝒜) ⟹ False"
  by (auto simp: ps_ta_def ps_rulesp_def ps_rules_def)

lemma ps_rules_not_empty_reach:
  assumes "Wrapp {||} |∈| ta_der (ps_ta 𝒜) (term_of_gterm t)"
  shows False using assms
proof (induction t)
  case (GFun f ts)
  then show ?case using ps_ta_nt_empty_set[of f _ 𝒜]
    by (auto simp: ps_ta_def)
qed

lemma ps_rules_complete:
  assumes "q |∈| ta_der 𝒜 (term_of_gterm t)"
  shows "∃p. q |∈| ex p ∧ p |∈| ta_der (ps_ta 𝒜) (term_of_gterm t) ∧ p |∈| ps_states 𝒜" using assms
proof (induction  rule: ta_der_gterm_induct)
  let ?P = "λt q p. q |∈| ex p ∧ p |∈| ta_der (ps_ta 𝒜) (term_of_gterm t) ∧ p |∈| ps_states 𝒜"
  case (GFun f ts ps p q)
  then have "∀i. ∃p. i < length ts ⟶ ?P (ts ! i) (ps ! i) p" by auto
  with choice[OF this] obtain psf where ps: "∀i < length ts. ?P (ts ! i) (ps ! i) (psf i)" by auto
  define qs where "qs = map psf [0 ..< length ts]"
  let ?p = "ps_reachable_states 𝒜 f (map ex qs)"
  from ps have in_Q: "fset_of_list qs |⊆| ps_states 𝒜"
    by (auto simp: qs_def fset_of_list_elem)
  from ps GFun(2) have all: "list_all2 (|∈|) ps (map ex qs)"
    by (auto simp: list_all2_conv_all_nth qs_def)
  then have in_p: "q |∈| ?p" using GFun(1, 3)
    unfolding ps_reachable_statesp_def ps_reachable_states_def by auto
  then have rule: "TA_rule f qs (Wrapp ?p) |∈| ps_rules 𝒜 (ps_states 𝒜)" using in_Q unfolding ps_rules_def
    by (intro ps_rulesI) (auto simp: ps_rulesp_def)
  from in_Q in_p have "Wrapp ?p |∈| (ps_states 𝒜)"
    by (auto intro!: ps_states_complete[unfolded ps_states_complete_it_def, rule_format])
  with in_p ps rule show ?case
    by (auto intro!: exI[of _ "Wrapp ?p"] exI[of _ qs] simp: ps_ta_def qs_def)
qed

lemma ps_ta_eps[simp]: "eps (ps_ta 𝒜) = {||}" by (auto simp: Let_def ps_ta_def)

lemma ps_ta_det[iff]: "ta_det (ps_ta 𝒜)" by (auto simp: Let_def ps_ta_def ta_det_def ps_rulesp_def ps_rules_def)

lemma ps_gta_lang:
  "gta_lang (ps_ta_Qf Q 𝒜) (ps_ta 𝒜) = gta_lang Q 𝒜" (is "?R = ?L")
proof standard
  show "?L ⊆ ?R" proof standard
    fix t assume "t ∈ ?L"
    then obtain q where q_res: "q |∈| ta_der 𝒜 (term_of_gterm t)" and q_final: "q |∈| Q"
      by auto
    from ps_rules_complete[OF q_res] obtain p where
      "p |∈| ps_states 𝒜" "q |∈| ex p" "p |∈| ta_der (ps_ta 𝒜) (term_of_gterm t)"
      by auto
    moreover with q_final have "p |∈| ps_ta_Qf Q 𝒜"
      by (auto simp: ps_ta_Qf_def)
    ultimately show "t ∈ ?R" by auto
  qed
  show "?R ⊆ ?L" proof standard
    fix t assume "t ∈ ?R"
    then obtain p where
      p_res: "p |∈| ta_der (ps_ta 𝒜) (term_of_gterm t)" and p_final: "p |∈| ps_ta_Qf Q 𝒜"
      by (auto simp: ta_lang_def)
    from ps_rules_sound[OF p_res] have "ex p |⊆| ta_der 𝒜 (term_of_gterm t)"
      by auto
    moreover from p_final obtain q where "q |∈| ex p" "q |∈| Q" by (auto simp:  ps_ta_Qf_def)
    ultimately show "t ∈ ?L" by auto
  qed
qed

definition ps_reg where
  "ps_reg R = Reg (ps_ta_Qf (fin R) (ta R)) (ps_ta (ta R))"

lemma ℒ_ps_reg:
  "ℒ (ps_reg R) = ℒ R"
  by (auto simp: ℒ_def ps_gta_lang ps_reg_def)

lemma ps_ta_states: "𝒬 (ps_ta 𝒜) |⊆| Wrapp |`| fPow (𝒬 𝒜)"
  using ps_rules_states ps_states unfolding ps_ta_def 𝒬_def
  by (auto simp: Let_def ps_rules_def) blast

lemma ps_ta_states': "ex |`| 𝒬 (ps_ta 𝒜) |⊆| fPow (𝒬 𝒜)"
  using ps_ta_states[of 𝒜]
  by fastforce

end
/head>

Theory Tree_Automata_Complement

theory Tree_Automata_Complement
  imports Tree_Automata_Det
begin

subsection ‹Complement closure of regular languages›

definition partially_completely_defined_on where
  "partially_completely_defined_on 𝒜 ℱ ⟷
    (∀ t. funas_gterm t ⊆ fset ℱ ⟷ (∃ q. q |∈| ta_der 𝒜 (term_of_gterm t)))"

definition sig_ta where
  "sig_ta ℱ = TA ((λ (f, n). TA_rule f (replicate n ()) ()) |`| ℱ) {||}"

lemma sig_ta_rules_fmember:
  "TA_rule f qs q |∈| rules (sig_ta ℱ) ⟷ (∃ n. (f, n) |∈| ℱ ∧ qs = replicate n () ∧ q = ())"
  by (auto simp: sig_ta_def fimage_iff fBex_def)

lemma sig_ta_completely_defined:
  "partially_completely_defined_on (sig_ta ℱ) ℱ"
proof -
  {fix t assume "funas_gterm t ⊆ fset ℱ"
    then have "() |∈| ta_der (sig_ta ℱ) (term_of_gterm t)"
    proof (induct t)
      case (GFun f ts)
      then show ?case
        by (auto simp: sig_ta_rules_fmember SUP_le_iff
                 simp flip: fmember.rep_eq intro!: exI[of _ "replicate (length ts) ()"])
    qed}
  moreover
  {fix t q assume "q |∈| ta_der (sig_ta ℱ) (term_of_gterm t)"
    then have "funas_gterm t ⊆ fset ℱ"
    proof (induct rule: ta_der_gterm_induct)
      case (GFun f ts ps p q)
      from GFun(1 - 4) GFun(5)[THEN subsetD] show ?case
        by (auto simp: sig_ta_rules_fmember simp flip: fmember.rep_eq dest!: in_set_idx)
      qed}
  ultimately show ?thesis
    unfolding partially_completely_defined_on_def
    by blast
qed

lemma ta_der_fsubset_sig_ta_completely:
  assumes "ta_subset (sig_ta ℱ) 𝒜" "ta_sig 𝒜 |⊆| ℱ"
  shows "partially_completely_defined_on 𝒜 ℱ"
proof -
  have "ta_der (sig_ta ℱ) t |⊆| ta_der 𝒜 t" for t
    using assms by (simp add: ta_der_mono')
  then show ?thesis using sig_ta_completely_defined assms(2)
    by (auto simp: partially_completely_defined_on_def)
       (metis ffunas_gterm.rep_eq fin_mono notin_fset ta_der_gterm_sig)
qed

lemma completely_definied_ps_taI:
  "partially_completely_defined_on 𝒜 ℱ ⟹ partially_completely_defined_on (ps_ta 𝒜) ℱ"
  unfolding partially_completely_defined_on_def
  using ps_rules_not_empty_reach[of 𝒜]
  using fsubsetD[OF ps_rules_sound[of _ 𝒜]] ps_rules_complete[of _ 𝒜]
  by (metis FSet_Lex_Wrapper.collapse fsubsetI fsubset_fempty)

lemma completely_definied_ta_union1I:
  "partially_completely_defined_on 𝒜 ℱ ⟹ ta_sig ℬ |⊆| ℱ ⟹ 𝒬 𝒜 |∩| 𝒬 ℬ = {||} ⟹
     partially_completely_defined_on (ta_union 𝒜 ℬ) ℱ"
  unfolding partially_completely_defined_on_def
  using ta_union_der_disj_states'[of 𝒜 ℬ]
  by (auto simp: ta_union_der_disj_states)
     (metis ffunas_gterm.rep_eq fsubset_trans less_eq_fset.rep_eq ta_der_gterm_sig)

lemma completely_definied_fmaps_statesI:
  "partially_completely_defined_on 𝒜 ℱ ⟹ finj_on f (𝒬 𝒜) ⟹ partially_completely_defined_on (fmap_states_ta f 𝒜) ℱ"
  unfolding partially_completely_defined_on_def
  using fsubsetD[OF ta_der_fmap_states_ta_mono2, of f 𝒜]
  using ta_der_to_fmap_states_der[of _ 𝒜 _ f]
  by (auto simp: fimage_iff fBex_def) fastforce+

lemma det_completely_defined_complement:
  assumes "partially_completely_defined_on 𝒜 ℱ" "ta_det 𝒜"
  shows "gta_lang (𝒬 𝒜 |-| Q) 𝒜 = 𝒯G (fset ℱ) - gta_lang Q 𝒜" (is "?Ls = ?Rs")
proof -
  {fix t assume "t ∈ ?Ls"
    then obtain p where p: "p |∈| 𝒬 𝒜" "p |∉| Q" "p |∈| ta_der 𝒜 (term_of_gterm t)"
      by auto
    from ta_detE[OF assms(2) p(3)] have "∀ q. q |∈| ta_der 𝒜 (term_of_gterm t) ⟶ q = p"
      by blast
    moreover have "funas_gterm t ⊆ fset ℱ"
      using p(3) assms(1) unfolding partially_completely_defined_on_def
      by (auto simp: less_eq_fset.rep_eq ffunas_gterm.rep_eq)
    ultimately have "t ∈ ?Rs" using p(2)
      by (auto simp: 𝒯G_equivalent_def)}
  moreover
  {fix t assume "t ∈ ?Rs"
    then have f: "funas_gterm t ⊆ fset ℱ" "∀ q. q |∈| ta_der 𝒜 (term_of_gterm t) ⟶ q |∉| Q"
      by (auto simp: 𝒯G_equivalent_def)
    from f(1) obtain p where "p |∈| ta_der 𝒜 (term_of_gterm t)" using assms(1)
      by (force simp: partially_completely_defined_on_def)
    then have "t ∈ ?Ls" using f(2)
      by (auto simp: gterm_ta_der_states intro: gta_langI[of p])}
  ultimately show ?thesis by blast
qed

lemma ta_der_gterm_sig_fset:
  "q |∈| ta_der 𝒜 (term_of_gterm t) ⟹ funas_gterm t ⊆ fset (ta_sig 𝒜)"
  using ta_der_gterm_sig
  by (metis ffunas_gterm.rep_eq less_eq_fset.rep_eq)

definition filter_ta_sig where
  "filter_ta_sig ℱ 𝒜 = TA (ffilter (λ r. (r_root r, length (r_lhs_states r)) |∈| ℱ) (rules 𝒜)) (eps 𝒜)"

definition filter_ta_reg where
  "filter_ta_reg ℱ R = Reg (fin R) (filter_ta_sig ℱ (ta R))"

lemma filter_ta_sig:
  "ta_sig (filter_ta_sig ℱ 𝒜) |⊆| ℱ"
  by (auto simp: ta_sig_def filter_ta_sig_def)

lemma filter_ta_sig_lang:
  "gta_lang Q (filter_ta_sig ℱ 𝒜) = gta_lang Q 𝒜 ∩ 𝒯G (fset ℱ)" (is "?Ls = ?Rs")
proof -
  let ?A = "filter_ta_sig ℱ 𝒜"
  {fix t assume "t ∈ ?Ls"
    then obtain q where q: "q |∈| Q" "q |∈| ta_der ?A (term_of_gterm t)"
      by auto
    then have "funas_gterm t ⊆ fset ℱ"
      using subset_trans[OF ta_der_gterm_sig_fset[OF q(2)] filter_ta_sig[unfolded less_eq_fset.rep_eq]]
      by blast
    then have "t ∈ ?Rs" using q
      by (auto simp: 𝒯G_equivalent_def filter_ta_sig_def
                 intro!: gta_langI[of q] ta_der_el_mono[where ?q = q and ℬ = 𝒜 and 𝒜 = ?A])}
  moreover
  {fix t assume ass: "t ∈ ?Rs"
    then have funas: "funas_gterm t ⊆ fset ℱ"
      by (auto simp: 𝒯G_equivalent_def)
    from ass obtain p where p: "p |∈| Q" "p |∈| ta_der 𝒜 (term_of_gterm t)"
      by auto
    from this(2) funas have "p |∈| ta_der ?A (term_of_gterm t)"
    proof (induct rule: ta_der_gterm_induct)
      case (GFun f ts ps p q)
      then show ?case
        by (auto simp: filter_ta_sig_def SUP_le_iff simp flip: fmember.rep_eq
                    intro!: exI[of _ ps] exI[of _ p])
    qed
    then have "t ∈ ?Ls" using p(1) by auto}
  ultimately show ?thesis by blast
qed

lemma ℒ_filter_ta_reg:
  "ℒ (filter_ta_reg ℱ 𝒜) = ℒ 𝒜 ∩ 𝒯G (fset ℱ)"
  using filter_ta_sig_lang
  by (auto simp: ℒ_def filter_ta_reg_def)

definition sig_ta_reg where
  "sig_ta_reg ℱ = Reg {||} (sig_ta ℱ)"

lemma ℒ_sig_ta_reg:
  "ℒ (sig_ta_reg ℱ) = {}"
  by (auto simp: ℒ_def sig_ta_reg_def)

definition complement_reg where
  "complement_reg R ℱ = (let 𝒜 = ps_reg (reg_union (sig_ta_reg ℱ) R) in
    Reg (𝒬r 𝒜 |-| fin 𝒜) (ta 𝒜))"

lemma ℒ_complement_reg:
  assumes "ta_sig (ta 𝒜) |⊆| ℱ"
  shows "ℒ (complement_reg 𝒜 ℱ) = 𝒯G (fset ℱ) - ℒ 𝒜"
proof -
  have "ℒ (complement_reg 𝒜 ℱ) = 𝒯G (fset ℱ) - ℒ (ps_reg (reg_union (sig_ta_reg ℱ) 𝒜))"
  unfolding ℒ_def complement_reg_def using assms
  by (auto simp: complement_reg_def Let_def ps_reg_def reg_union_def sig_ta_reg_def
                 sig_ta_completely_defined finj_Inl_Inr
           intro!: det_completely_defined_complement completely_definied_ps_taI
                   completely_definied_ta_union1I completely_definied_fmaps_statesI)
  then show ?thesis
    by (auto simp: ℒ_ps_reg ℒ_union ℒ_sig_ta_reg)
qed

lemma ℒ_complement_filter_reg:
   "ℒ (complement_reg (filter_ta_reg ℱ 𝒜) ℱ) = 𝒯G (fset ℱ) - ℒ 𝒜"
proof -
  have *: "ta_sig (ta (filter_ta_reg ℱ 𝒜)) |⊆| ℱ"
    by (auto simp: filter_ta_reg_def filter_ta_sig)
  show ?thesis unfolding ℒ_complement_reg[OF *] ℒ_filter_ta_reg
    by blast
qed

definition difference_reg where
  "difference_reg R L = (let F = ta_sig (ta R) in
     reg_intersect R (trim_reg (complement_reg (filter_ta_reg F L) F)))"

lemma ℒ_difference_reg:
  "ℒ (difference_reg R L) = ℒ R - ℒ L" (is "?Ls = ?Rs")
  unfolding difference_reg_def Let_def ℒ_trim ℒ_intersect ℒ_complement_filter_reg
  using reg_funas by blast

end
ad>

Theory Tree_Automata_Pumping

theory Tree_Automata_Pumping
  imports Tree_Automata
begin

subsection ‹Pumping lemma›

(* We need to deal with non deterministic tree automata,
   to show the pumping lemma we need to find cycles on the derivation
   of terms with depth greater than the number of states.

  assumes "card (ta_states A) < depth t" and "finite (ta_states A)"
      and "q ∈ ta_res A t" and "ground t"
    shows "∃ s v p. t ⊵ s ∧ s ⊳ v ∧ p ∈ ta_res A v ∧ p ∈ ta_res A s"

  we only get t ⟶* q, v ⟶ p, s ⟶ p, but we have no chance to conclude
  that the state p appears in the derivation t ⟶* q, because our derivation is
  not deterministic and there could be a cycle in the derivation of t which does not
  end in state q.
 *)

abbreviation "derivation_ctxt ts Cs ≡ Suc (length Cs) = length ts ∧
  (∀ i < length Cs. (Cs ! i) ⟨ts ! i⟩ = ts ! Suc i)"

abbreviation "derivation_ctxt_st A ts Cs qs ≡ length qs = length ts ∧ Suc (length Cs) = length ts ∧
  (∀ i < length Cs. qs ! Suc i |∈| ta_der A (Cs ! i)⟨Var (qs ! i)⟩)"

abbreviation "derivation_sound A ts qs ≡ length qs = length ts ∧
  (∀ i < length qs. qs ! i |∈| ta_der A (ts ! i))"
 
definition "derivation A ts Cs qs ⟷ derivation_ctxt ts Cs ∧
  derivation_ctxt_st A ts Cs qs ∧ derivation_sound A ts qs"


(* Context compositions from left *)
lemma ctxt_comp_lhs_not_hole:
  assumes "C ≠ □"
  shows "C ∘c D ≠ □"
  using assms by (cases C; cases D) auto

lemma ctxt_comp_rhs_not_hole:
  assumes "D ≠ □"
  shows "C ∘c D ≠ □"
  using assms by (cases C; cases D) auto

lemma fold_ctxt_comp_nt_empty_acc:
  assumes "D ≠ □"
  shows "fold (∘c) Cs D ≠ □"
  using assms by (induct Cs arbitrary: D) (auto simp add: ctxt_comp_rhs_not_hole)

lemma fold_ctxt_comp_nt_empty:
  assumes "C ∈ set Cs" and "C ≠ □"
  shows "fold (∘c) Cs D ≠ □" using assms
  by (induct Cs arbitrary: D) (auto simp: ctxt_comp_lhs_not_hole fold_ctxt_comp_nt_empty_acc)

(* Rep of context *)

lemma empty_ctxt_power [simp]:
  "□ ^ n = □"
  by (induct n) auto

lemma ctxt_comp_not_hole:
  assumes "C ≠ □" and "n ≠ 0"
  shows "C^n ≠ □"
  using assms by (induct n arbitrary: C) (auto elim!: ctxt_compose.elims)

lemma ctxt_comp_n_suc [simp]:
  shows "(C^(Suc n))⟨t⟩ = (C^n)⟨C⟨t⟩⟩"
  by (induct n arbitrary: C) auto

lemma ctxt_comp_reach:
  assumes "p |∈| ta_der A C⟨Var p⟩"
  shows "p |∈| ta_der A (C^n)⟨Var p⟩"
  using assms by (induct n arbitrary: C) (auto intro: ta_der_ctxt)


(* Connecting positions to term depth and trivial depth lemmas *)

lemma args_depth_less [simp]:
  assumes "u ∈ set ss"
  shows "depth u < depth (Fun f ss)" using assms
  by (cases ss) (auto simp: less_Suc_eq_le)

lemma subterm_depth_less:
  assumes "s ⊳ t"
  shows "depth t < depth s"
  using assms by (induct s t rule: supt.induct) (auto intro: less_trans)

lemma poss_length_depth:
  shows "∃ p ∈ poss t. length p = depth t"
proof (induct t)
  case (Fun f ts)
  then show ?case
  proof (cases ts)
    case [simp]: (Cons a list)
    have "ts ≠ [] ⟹ ∃ s. f s = Max (f ` set ts) ∧ s ∈ set ts" for ts f
    using Max_in[of "f ` set ts"] by (auto simp: image_iff)
    from this[of ts depth] obtain s where s: "depth s = Max (depth ` set ts) ∧ s ∈ set ts"
      by auto
    then show ?thesis using Fun[of s] in_set_idx[OF conjunct2[OF s]]
      by fastforce
  qed auto
qed auto

lemma poss_length_bounded_by_depth:
  assumes "p ∈ poss t"
  shows "length p ≤ depth t" using assms
  by (induct t arbitrary: p) (auto intro!: Suc_leI, meson args_depth_less dual_order.strict_trans2 nth_mem)

(* Connecting depth to ctxt repetition *)

lemma depth_ctxt_nt_hole_inc:
  assumes "C ≠ □"
  shows "depth t < depth C⟨t⟩" using assms
  using subterm_depth_less[of t "C⟨t⟩"]
  by (simp add: nectxt_imp_supt_ctxt subterm_depth_less) 

lemma depth_ctxt_less_eq:
  "depth t ≤ depth C⟨t⟩" using depth_ctxt_nt_hole_inc less_imp_le
  by (cases C, simp) blast  

lemma ctxt_comp_n_not_hole_depth_inc:
  assumes "C ≠ □"
  shows "depth (C^n)⟨t⟩ < depth (C^(Suc n))⟨t⟩"
  using assms by (induct n arbitrary: C t) (auto simp: ctxt_comp_not_hole depth_ctxt_nt_hole_inc)

lemma ctxt_comp_n_lower_bound:
  assumes "C ≠ □"
  shows "n < depth (C^(Suc n))⟨t⟩"
  using assms
proof (induct n arbitrary: C)
  case 0 then show ?case using ctxt_comp_not_hole depth_ctxt_nt_hole_inc gr_implies_not_zero by blast
next
  case (Suc n) then show ?case using ctxt_comp_n_not_hole_depth_inc less_trans_Suc by blast  
qed

lemma ta_der_ctxt_n_loop:
  assumes "q |∈| ta_der 𝒜 t" "q |∈| ta_der 𝒜 C⟨Var q⟩"
  shows " q |∈| ta_der 𝒜 (C^n)⟨t⟩"
  using assms by (induct n) (auto simp: ta_der_ctxt)

lemma ctxt_compose_funs_ctxt [simp]:
  "funs_ctxt (C ∘c D) = funs_ctxt C ∪ funs_ctxt D"
  by (induct C arbitrary: D) auto

lemma ctxt_compose_vars_ctxt [simp]:
  "vars_ctxt (C ∘c D) = vars_ctxt C ∪ vars_ctxt D"
  by (induct C arbitrary: D) auto

lemma ctxt_power_funs_vars_0 [simp]:
  assumes "n = 0"
  shows "funs_ctxt (C^n) = {}" "vars_ctxt (C^n) = {}" 
  using assms by auto

lemma ctxt_power_funs_vars_n [simp]:
  assumes "n ≠ 0"
  shows "funs_ctxt (C^n) = funs_ctxt C" "vars_ctxt (C^n) = vars_ctxt C" 
  using assms by (induct n arbitrary: C, auto) fastforce+ 


(* Collect all terms in a path via positions *)

fun terms_pos where
  "terms_pos s [] = [s]"
| "terms_pos s (p # ps) = terms_pos (s |_ [p]) ps @ [s]"

lemma subt_at_poss [simp]:
  assumes "a # p ∈ poss s"
  shows "p ∈ poss (s |_ [a])"
  using assms by (metis append_Cons append_self_conv2 poss_append_poss)

lemma terms_pos_length [simp]:
  shows "length (terms_pos t p) = Suc (length p)"
  by (induct p arbitrary: t) auto

lemma terms_pos_last [simp]:
  assumes "i = length p"
  shows "terms_pos t p ! i = t" using assms
  by (induct p arbitrary: t) (auto simp add: append_Cons_nth_middle)

lemma terms_pos_subterm:
  assumes "p ∈ poss t" and "s ∈ set (terms_pos t p)"
  shows "t ⊵ s" using assms
  using assms
proof (induct p arbitrary: t s)
  case (Cons a p)
  from Cons(2) have st: "t ⊵ t |_ [a]" by auto
  from Cons(1)[of "t |_ [a]"] Cons(2-) show ?case
    using supteq_trans[OF st] by fastforce
qed auto

lemma terms_pos_differ_subterm:
  assumes "p ∈ poss t" and "i < length (terms_pos t p)"
     and "j < length (terms_pos t p)" and "i < j"
   shows "terms_pos t p ! i ⊲ terms_pos t p ! j"
  using assms
proof (induct p arbitrary: t i j)
  case (Cons a p)
  from Cons(2-) have "t |_ [a] ⊵ terms_pos (t |_ [a]) p ! i"
    by (intro terms_pos_subterm[of p]) auto
  from subterm.order.strict_trans1[OF this, of t] Cons(1)[of "t |_ [a]" i j] Cons(2-) show ?case
    by (cases "j = length (a # p)") (force simp add: append_Cons_nth_middle append_Cons_nth_left)+
qed auto

lemma distinct_terms_pos:
  assumes "p ∈ poss t"
  shows "distinct (terms_pos t p)" using assms
proof (induct p arbitrary: t)
  case (Cons a p)
  have "⋀i. i < Suc (length p) ⟹ t ⊳ (terms_pos (t |_ [a]) p) ! i"
    using terms_pos_differ_subterm[OF Cons(2), of _  "Suc (length p)"] by (auto simp: nth_append) 
  then show ?case using  Cons(1)[of "t |_ [a]"] Cons(2-)
    by (auto simp: in_set_conv_nth) (metis supt_not_sym)
qed auto


lemma term_chain_depth:
  assumes "depth t = n"
  shows "∃ p ∈ poss t. length (terms_pos t p) = (n + 1)"
proof -
  obtain p where p: "p ∈ poss t" "length p = depth t"
    using poss_length_depth[of t] by blast
  from terms_pos_length[of t p] this show ?thesis using assms
    by auto
qed

lemma ta_der_derivation_chain_terms_pos_exist:
  assumes "p ∈ poss t" and "q |∈| ta_der A t"
  shows "∃ Cs qs. derivation A (terms_pos t p) Cs qs ∧ last qs = q"
  using assms         
proof (induct p arbitrary: t q)
  case Nil
  then show ?case by (auto simp: derivation_def intro!: exI[of _ "[q]"])
next
  case (Cons a p)
  from Cons(2) have poss: "p ∈ poss (t |_ [a])" by auto
  from Cons(2) obtain C where C: "C⟨t |_ [a]⟩ = t"
    using ctxt_at_pos_subt_at_id poss_Cons by blast
  from C ta_der_ctxt_decompose Cons(3) obtain q' where
    res: "q' |∈| ta_der A (t |_ [a])" "q |∈| ta_der A C⟨Var q'⟩"
    by metis
  from Cons(1)[OF _ res(1)] Cons(2-) C obtain Cs qs where
    der: "derivation A (terms_pos (t |_ [a]) p) Cs qs ∧ last qs = q'"
    by (auto simp del: terms_pos.simps)
  {fix i assume "i < Suc (length Cs)"
    then have "derivation_ctxt (terms_pos (t |_ [a]) p @ [t]) (Cs @ [C])"
      using der C[symmetric] unfolding derivation_def
      by (cases "i = length Cs") (auto simp: nth_append_Cons)}
  note der_ctxt = this
  {fix i assume "i < Suc (length Cs)"
    then have "derivation_ctxt_st A (terms_pos (t |_ [a]) p @ [t]) (Cs @ [C]) (qs @ [q])"
      using der poss C res(2) last_conv_nth[of qs]
      by (cases "i = length Cs", auto 0 0 simp: derivation_def nth_append not_less less_Suc_eq) fastforce+}
  then show ?case using C poss res(1) der_ctxt der
    by (auto simp: derivation_def intro!: exI[of _ "Cs @ [C]"] exI[of _ "qs @ [q]"])
      (simp add: Cons.prems(2) nth_append_Cons)
qed

lemma derivation_ctxt_terms_pos_nt_empty:
  assumes "p ∈ poss t" and "derivation_ctxt (terms_pos t p) Cs" and "C ∈ set Cs"
  shows "C ≠ □"
  using assms by (auto simp: in_set_conv_nth)
    (metis Suc_mono assms(2) ctxt_apply_term.simps(1) distinct_terms_pos lessI less_SucI less_irrefl_nat nth_eq_iff_index_eq)

lemma derivation_ctxt_terms_pos_sub_list_nt_empty:
  assumes "p ∈ poss t" and "derivation_ctxt (terms_pos t p) Cs"
    and "i < length Cs" and "j ≤ length Cs" and "i < j"
  shows "fold (∘c) (take (j - i) (drop i Cs)) □ ≠ □"
proof -
  have "∃ C. C ∈ set (take (j - i) (drop i Cs))"
    using assms(3-) not_le by fastforce
  then obtain C where w: "C ∈ set (take (j - i) (drop i Cs))" by blast
  then have "C ≠ □"
    by auto (meson assms(1, 2) derivation_ctxt_terms_pos_nt_empty in_set_dropD in_set_takeD) 
  then show ?thesis by (auto simp: fold_ctxt_comp_nt_empty[OF w])
qed

lemma derivation_ctxt_comp_term:
  assumes "derivation_ctxt ts Cs"
    and "i < length Cs" and "j ≤ length Cs" and "i < j"
  shows "(fold (∘c) (take (j - i) (drop i Cs)) □)⟨ts ! i⟩ = ts ! j"
  using assms
proof (induct "j - i" arbitrary: j i)
  case (Suc x)
  then obtain n where j [simp]: "j = Suc n" by (meson lessE)
  then have r: "x = n - i" "Suc n - i = 1 + (n - i)" using Suc(2, 6) by linarith+
  then show ?case using Suc(1)[OF r(1)] Suc(2-) unfolding j r(2) take_add[of "n - i" 1]
    by (cases "i = n") (auto simp: take_Suc_conv_app_nth)
qed auto

lemma derivation_ctxt_comp_states:
  assumes "derivation_ctxt_st A ts Cs qs"
    and "i < length Cs" and "j ≤ length Cs" and "i < j"
  shows "qs ! j |∈| ta_der A (fold (∘c) (take (j - i) (drop i Cs)) □)⟨Var (qs ! i)⟩"
  using assms
proof (induct "j - i" arbitrary: j i)
  case (Suc x)
  then obtain n where j [simp]: "j = Suc n" by (meson lessE)
  then have r: "x = n - i" "Suc n - i = 1 + (n - i)" using Suc(2, 6) by linarith+  
  then show ?case using Suc(1)[OF r(1)] Suc(2-) unfolding j r(2) take_add[of "n - i" 1]
    by (cases "i = n") (auto simp: take_Suc_conv_app_nth ta_der_ctxt)
qed auto

lemma terms_pos_ground:
  assumes "ground t" and "p ∈ poss t"
  shows "∀ s ∈ set (terms_pos t p). ground s"
  using terms_pos_subterm[OF assms(2)] subterm_eq_pres_ground[OF assms(1)] by simp


lemma list_card_smaller_contains_eq_elemens:
  assumes "length qs = n" and "card (set qs) < n"
  shows "∃ i < length qs. ∃ j < length qs. i < j ∧ qs ! i = qs ! j"
  using assms by auto (metis distinct_card distinct_conv_nth linorder_neqE_nat) 

lemma length_remdups_less_eq:
  assumes "set xs ⊆ set ys"
  shows "length (remdups xs) ≤ length (remdups ys)" using assms
  by (auto simp: length_remdups_card_conv card_mono)

(* Main lemma *)

lemma pigeonhole_tree_automata:
  assumes "fcard (𝒬 A) < depth t" and "q |∈| ta_der A t" and "ground t"
  shows "∃ C C2 v p. C2 ≠ □ ∧ C⟨C2⟨v⟩⟩ = t ∧ p |∈| ta_der A v ∧
     p |∈| ta_der A C2⟨Var p⟩ ∧ q |∈| ta_der A C⟨Var p⟩"
proof -
  obtain p n where p: "p ∈ poss t"  "depth t = n" and
    card: "fcard (𝒬 A) < n" "length (terms_pos t p) = (n + 1)"
    using assms(1) term_chain_depth by blast
  from ta_der_derivation_chain_terms_pos_exist[OF p(1) assms(2)] obtain Cs qs where
    derivation: "derivation A (terms_pos t p) Cs qs ∧ last qs = q" by blast
  then have d_ctxt: "derivation_ctxt_st A (terms_pos t p) Cs qs" "derivation_ctxt (terms_pos t p) Cs"
    by (auto simp: derivation_def)
  then have l: "length Cs = length qs - 1" by (auto simp: derivation_def)
  from derivation have sub: "fset_of_list qs |⊆| 𝒬 A" "length qs = length (terms_pos t p)"
    unfolding derivation_def
    using ta_der_states[of A "t |_ i" for i] terms_pos_ground[OF assms(3) p(1)]
    by auto (metis derivation derivation_def gterm_of_term_inv gterm_ta_der_states in_fset_conv_nth nth_mem)
  then have "∃ i < length (butlast qs). ∃ j < length (butlast qs). i < j ∧ (butlast qs) ! i = (butlast qs) ! j"
    using card(1, 2) assms(1) fcard_mono[OF sub(1)] length_remdups_less_eq[of "butlast qs" qs]
    by (intro list_card_smaller_contains_eq_elemens[of "butlast qs" n])
       (auto simp: card_set fcard_fset in_set_butlastD subsetI
                 intro!: le_less_trans[of "length (remdups (butlast qs))" "fcard (𝒬 A)" "length p"])
  then obtain i j where len: "i < length Cs" "j < length Cs" and less: "i < j" and st: "qs ! i = qs ! j"
    unfolding l length_butlast by (auto simp: nth_butlast)
  then have gt_0: "0 < length Cs" and gt_j: "0 < j" using len less less_trans by auto
  have "fold (∘c) (take (j - i) (drop i Cs)) □ ≠ □"
    using derivation_ctxt_terms_pos_sub_list_nt_empty[OF p(1) d_ctxt(2) len(1) order.strict_implies_order[OF len(2)] less] .
  moreover have "(fold (∘c) (take (length Cs - j) (drop j Cs)) □)⟨terms_pos t p ! j⟩ = terms_pos t p ! length Cs"
    using derivation_ctxt_comp_term[OF d_ctxt(2) len(2) _ len(2)] len(2) by auto
  moreover have "(fold (∘c) (take (j - i) (drop i Cs)) □)⟨terms_pos t p ! i⟩ = terms_pos t p ! j"
    using derivation_ctxt_comp_term[OF d_ctxt(2) len(1) _ less] len(2) by auto
  moreover have "qs ! j |∈| ta_der A (terms_pos t p ! i)" using derivation len
    by (auto simp: derivation_def st[symmetric])
  moreover have "qs ! j |∈| ta_der A (fold (∘c) (take (j - i) (drop i Cs)) □)⟨Var (qs ! i)⟩"
    using derivation_ctxt_comp_states[OF d_ctxt(1) len(1) _ less] len(2) st by simp
  moreover have "q |∈| ta_der A (fold (∘c) (take (length Cs - j) (drop j Cs)) □)⟨Var (qs ! j)⟩"
    using derivation_ctxt_comp_states[OF d_ctxt(1) len(2) _ len(2)] conjunct2[OF derivation]
    by (auto simp: l sub(2)) (metis Suc_inject Zero_not_Suc d_ctxt(1) l last_conv_nth list.size(3) terms_pos_length)
  ultimately show ?thesis using st d_ctxt(1) by (metis Suc_inject terms_pos_last terms_pos_length)
qed

end
ody>

Theory Myhill_Nerode

theory Myhill_Nerode
  imports Tree_Automata Ground_Ctxt
begin

subsection ‹Myhill Nerode characterization for regular tree languages›

lemma ground_ctxt_apply_pres_der:
  assumes "ta_der 𝒜 (term_of_gterm s) = ta_der 𝒜 (term_of_gterm t)"
  shows "ta_der 𝒜 (term_of_gterm C⟨s⟩G) = ta_der 𝒜 (term_of_gterm C⟨t⟩G)" using assms
  by (induct C) (auto, (metis append_Cons_nth_not_middle nth_append_length)+)

locale myhill_nerode =
  fixes ℱ ℒ assumes term_subset: "ℒ ⊆ 𝒯G ℱ"
begin

definition myhill ("_ ≡ℒ _") where
  "myhill s t ≡ s ∈ 𝒯G ℱ ∧ t ∈ 𝒯G ℱ ∧ (∀ C. C⟨s⟩G ∈ ℒ ∧ C⟨t⟩G ∈ ℒ ∨ C⟨s⟩G ∉ ℒ ∧ C⟨t⟩G ∉ ℒ)"

lemma myhill_sound: "s ≡ℒ t ⟹ s ∈ 𝒯G ℱ"  "s ≡ℒ t ⟹ t ∈ 𝒯G ℱ"
  unfolding myhill_def by auto

lemma myhill_refl [simp]: "s ∈ 𝒯G ℱ ⟹ s ≡ℒ s"
  unfolding myhill_def by auto

lemma myhill_symmetric: "s ≡ℒ t ⟹ t ≡ℒ s"
  unfolding myhill_def by auto

lemma myhill_trans [trans]:
  "s ≡ℒ t ⟹ t ≡ℒ u ⟹ s ≡ℒ u"
  unfolding myhill_def by auto

abbreviation myhill_r ("MNℒ") where
  "myhill_r ≡ {(s, t) | s t. s ≡ℒ t}"

lemma myhill_equiv:
  "equiv (𝒯G ℱ) MNℒ"
  apply (intro equivI) apply (auto simp: myhill_sound myhill_symmetric sym_def trans_def refl_on_def)
  using myhill_trans by blast

lemma rtl_der_image_on_myhill_inj:
  assumes "gta_lang Qf 𝒜 = ℒ"
  shows "inj_on (λ X. gta_der 𝒜 ` X) (𝒯G ℱ // MNℒ)" (is "inj_on ?D ?R")
proof -
  {fix S T assume eq_rel: "S ∈ ?R" "T ∈ ?R" "?D S = ?D T"
    have "⋀ s t. s ∈ S ⟹ t ∈ T ⟹ s ≡ℒ t"
    proof -
      fix s t assume mem: "s ∈ S" "t ∈ T"
      then obtain t' where res: "t' ∈ T" "gta_der 𝒜 s = gta_der 𝒜 t'" using eq_rel(3)
        by (metis image_iff)
      from res(1) mem have "s ∈ 𝒯G ℱ" "t ∈ 𝒯G ℱ" "t' ∈ 𝒯G ℱ" using eq_rel(1, 2)
        using in_quotient_imp_subset myhill_equiv by blast+
      then have "s ≡ℒ t'" using assms res ground_ctxt_apply_pres_der[of 𝒜 s]
        by (auto simp: myhill_def gta_der_def simp flip: ctxt_of_gctxt_apply
         elim!: gta_langE intro: gta_langI)
      moreover have "t' ≡ℒ t" using quotient_eq_iff[OF myhill_equiv eq_rel(2) eq_rel(2) res(1) mem(2)]
        by simp
      ultimately show "s ≡ℒ t" using myhill_trans by blast
    qed
    then have "⋀ s t. s ∈ S ⟹ t ∈ T ⟹ (s, t) ∈ MNℒ" by blast
    then have "S = T" using quotient_eq_iff[OF myhill_equiv eq_rel(1, 2)]
      using eq_rel(3) by fastforce}
  then show inj: "inj_on ?D ?R" by (meson inj_onI)
qed

lemma rtl_implies_finite_indexed_myhill_relation:
  assumes "gta_lang Qf 𝒜 = ℒ"
  shows "finite (𝒯G ℱ // MNℒ)" (is "finite ?R")
proof -
  let ?D = "λ X. gta_der 𝒜 ` X"
  have image: "?D ` ?R ⊆ Pow (fset (fPow (𝒬 𝒜)))" unfolding gta_der_def
    by (meson PowI fPowI ground_ta_der_states ground_term_of_gterm image_subsetI notin_fset)
  then have "finite (Pow (fset (fPow (𝒬 𝒜))))" by simp
  then have "finite (?D ` ?R)" using finite_subset[OF image] by fastforce
  then show ?thesis using finite_image_iff[OF rtl_der_image_on_myhill_inj[OF assms]]
    by blast
qed

end

end
class="head">

Theory GTT

theory GTT
  imports Tree_Automata Ground_Closure
begin

section ‹Ground Tree Transducers (GTT)›

(* A GTT 𝒢 consists of a set of interface states and
   a set of rules for automaton 𝒜 and one for ℬ. *)
type_synonym ('q, 'f) gtt = "('q, 'f) ta × ('q, 'f) ta"

abbreviation gtt_rules where
  "gtt_rules 𝒢 ≡ rules (fst 𝒢) |∪| rules (snd 𝒢)"
abbreviation gtt_eps where
  "gtt_eps 𝒢 ≡ eps (fst 𝒢) |∪| eps (snd 𝒢)"
definition gtt_states where
  "gtt_states 𝒢 = 𝒬 (fst 𝒢) |∪| 𝒬 (snd 𝒢)"
abbreviation gtt_syms where
  "gtt_syms 𝒢 ≡ ta_sig (fst 𝒢) |∪| ta_sig (snd 𝒢)"
definition gtt_interface where
  "gtt_interface 𝒢 = 𝒬 (fst 𝒢) |∩| 𝒬 (snd 𝒢)"
definition gtt_eps_free where
  "gtt_eps_free 𝒢 = (eps_free (fst 𝒢), eps_free (snd 𝒢))"

definition is_gtt_eps_free :: "('q, 'f) ta × ('p, 'g) ta ⇒ bool" where
  "is_gtt_eps_free 𝒢 ⟷ eps (fst 𝒢) = {||} ∧ eps (snd 𝒢) = {||}"

text ‹*anchored* language accepted by a GTT›

definition agtt_lang :: "('q, 'f) gtt ⇒ 'f gterm rel" where
  "agtt_lang 𝒢 = {(t, u) |t u q. q |∈| gta_der (fst 𝒢) t ∧ q |∈| gta_der (snd 𝒢) u}"

lemma agtt_langI:
  "q |∈| gta_der (fst 𝒢) s ⟹ q |∈| gta_der (snd 𝒢) t ⟹ (s, t) ∈ agtt_lang 𝒢"
  by (auto simp: agtt_lang_def)

lemma agtt_langE:
  assumes "(s, t) ∈ agtt_lang 𝒢"
  obtains q where "q |∈| gta_der (fst 𝒢) s" "q |∈| gta_der (snd 𝒢) t"
  using assms by (auto simp: agtt_lang_def)

lemma converse_agtt_lang:
  "(agtt_lang 𝒢)¯ = agtt_lang (prod.swap 𝒢)"
  by (auto simp: agtt_lang_def)

lemma agtt_lang_swap:
  "agtt_lang (prod.swap 𝒢) = prod.swap ` agtt_lang 𝒢"
  by (auto simp: agtt_lang_def)

text ‹language accepted by a GTT›

abbreviation gtt_lang :: "('q, 'f) gtt ⇒ 'f gterm rel" where
  "gtt_lang 𝒢 ≡ gmctxt_cl UNIV (agtt_lang 𝒢)"  

lemma gtt_lang_join:
  "q |∈| gta_der (fst 𝒢) s ⟹ q |∈| gta_der (snd 𝒢) t ⟹ (s, t) ∈ gmctxt_cl UNIV (agtt_lang 𝒢)"
  by (auto simp: agtt_lang_def)

definition gtt_accept where
  "gtt_accept 𝒢 s t ≡ (s, t) ∈ gmctxt_cl UNIV (agtt_lang 𝒢)"

lemma gtt_accept_intros:
  "(s, t) ∈ agtt_lang 𝒢 ⟹ gtt_accept 𝒢 s t"
  "length ss = length ts ⟹ ∀ i < length ts. gtt_accept 𝒢 (ss ! i) (ts ! i) ⟹
    (f, length ss) ∈ ℱ ⟹ gtt_accept 𝒢 (GFun f ss) (GFun f ts)"
  by (auto simp: gtt_accept_def)

abbreviation gtt_lang_terms :: "('q, 'f) gtt ⇒ ('f, 'q) term rel" where
  "gtt_lang_terms 𝒢 ≡ (λ s. map_both term_of_gterm s) ` (gmctxt_cl UNIV (agtt_lang 𝒢))"

lemma term_of_gterm_gtt_lang_gtt_lang_terms_conv:
  "map_both term_of_gterm ` gtt_lang 𝒢 = gtt_lang_terms 𝒢"
  by auto

lemma gtt_accept_swap [simp]:
  "gtt_accept (prod.swap 𝒢) s t ⟷ gtt_accept 𝒢 t s"
  by (auto simp: gmctxt_cl_swap agtt_lang_swap gtt_accept_def)

lemma gtt_lang_swap:
  "(gtt_lang (A, B))¯ = gtt_lang (B, A)"
  using gtt_accept_swap[of "(A, B)"]
  by (auto simp: gtt_accept_def)

(* The following Lemmas are about ta_res' *)

lemma gtt_accept_exI:
  assumes "gtt_accept 𝒢 s t"
  shows "∃ u. u |∈| ta_der' (fst 𝒢) (term_of_gterm s) ∧ u |∈| ta_der' (snd 𝒢) (term_of_gterm t)"
  using assms unfolding gtt_accept_def
proof (induction)
  case (base s t)
  then show ?case unfolding agtt_lang_def
    by (auto simp: gta_der_def ta_der_to_ta_der')
next
  case (step ss ts f)
  then have inner: "∃ us. length us = length ss ∧
    (∀i < length ss. (us ! i) |∈| ta_der' (fst 𝒢) (term_of_gterm (ss ! i)) ∧
    (us ! i) |∈| ta_der' (snd 𝒢) (term_of_gterm (ts ! i)))"
    using Ex_list_of_length_P[of "length ss" "λ u i. u |∈| ta_der' (fst 𝒢) (term_of_gterm (ss ! i)) ∧
      u |∈| ta_der' (snd 𝒢) (term_of_gterm (ts ! i))"]
    by auto
  then obtain us where "length us = length ss ∧ (∀i < length ss.
            (us ! i) |∈| ta_der' (fst 𝒢) (term_of_gterm (ss ! i)) ∧ (us ! i) |∈| ta_der' (snd 𝒢) (term_of_gterm (ts ! i)))"
    by blast
  then have "Fun f us |∈| ta_der' (fst 𝒢) (Fun f (map term_of_gterm ss)) ∧
         Fun f us |∈| ta_der' (snd 𝒢) (Fun f (map term_of_gterm ts))" using step(1) by fastforce
  then show ?case by (metis term_of_gterm.simps) 
qed


lemma agtt_lang_mono:
  assumes "rules (fst 𝒢) |⊆| rules (fst 𝒢')" "eps (fst 𝒢) |⊆| eps (fst 𝒢')"
    "rules (snd 𝒢) |⊆| rules (snd 𝒢')" "eps (snd 𝒢) |⊆| eps (snd 𝒢')"
  shows "agtt_lang 𝒢 ⊆ agtt_lang 𝒢'"
  using fsubsetD[OF ta_der_mono[OF assms(1, 2)]] ta_der_mono[OF assms(3, 4)]
  by (auto simp: agtt_lang_def gta_der_def dest!: fsubsetD[OF ta_der_mono[OF assms(1, 2)]] fsubsetD[OF ta_der_mono[OF assms(3, 4)]])

lemma gtt_lang_mono:
  assumes "rules (fst 𝒢) |⊆| rules (fst 𝒢')" "eps (fst 𝒢) |⊆| eps (fst 𝒢')" 
    "rules (snd 𝒢) |⊆| rules (snd 𝒢')" "eps (snd 𝒢) |⊆| eps (snd 𝒢')"
  shows "gtt_lang 𝒢 ⊆ gtt_lang 𝒢'"
  using agtt_lang_mono[OF assms]
  by (intro gmctxt_cl_mono_rel) auto

definition fmap_states_gtt where
  "fmap_states_gtt f ≡ map_both (fmap_states_ta f)"

lemma ground_map_vars_term_simp:
  "ground t ⟹ map_term f g t = map_term f (λ_. undefined) t"
  by (induct t) auto

lemma states_fmap_states_gtt [simp]:
  "gtt_states (fmap_states_gtt f 𝒢) = f |`| gtt_states 𝒢"
  by (simp add: fimage_funion gtt_states_def fmap_states_gtt_def)

lemma agtt_lang_fmap_states_gtt:
  assumes "finj_on f (gtt_states 𝒢)"
  shows "agtt_lang (fmap_states_gtt f 𝒢) = agtt_lang 𝒢" (is "?Ls = ?Rs")
proof -
  from assms have inj: "finj_on f (𝒬 (fst 𝒢) |∪| 𝒬 (snd 𝒢))" "finj_on f (𝒬 (fst 𝒢))" "finj_on f (𝒬 (snd 𝒢))"
    by (auto simp: gtt_states_def finj_on_fUn)
  then have "?Ls ⊆ ?Rs" using ta_der_fmap_states_inv_superset[OF _ inj(1)]
    by (auto simp: agtt_lang_def gta_der_def fmap_states_gtt_def)
  moreover have "?Rs ⊆ ?Ls"
    by (auto simp: agtt_lang_def gta_der_def fmap_states_gtt_def elim!: ta_der_to_fmap_states_der)
  ultimately show ?thesis by blast
qed

lemma agtt_lang_Inl_Inr_states_agtt:
  "agtt_lang (fmap_states_gtt Inl 𝒢) = agtt_lang 𝒢"
  "agtt_lang (fmap_states_gtt Inr 𝒢) = agtt_lang 𝒢"
  by (auto simp: finj_Inl_Inr intro!: agtt_lang_fmap_states_gtt)

lemma gtt_lang_fmap_states_gtt:
  assumes "finj_on f (gtt_states 𝒢)"
  shows "gtt_lang (fmap_states_gtt f 𝒢) = gtt_lang 𝒢" (is "?Ls = ?Rs")
  unfolding fmap_states_gtt_def
  using agtt_lang_fmap_states_gtt[OF assms]
  by (simp add: fmap_states_gtt_def)

definition gtt_only_reach where
  "gtt_only_reach = map_both ta_only_reach"

subsection ‹(A)GTT reachable states›

lemma agtt_only_reach_lang:
  "agtt_lang (gtt_only_reach 𝒢) = agtt_lang 𝒢"
  unfolding agtt_lang_def gtt_only_reach_def
  by (auto simp: gta_der_def simp flip: ta_der_gterm_only_reach)

lemma gtt_only_reach_lang:
  "gtt_lang (gtt_only_reach 𝒢) = gtt_lang 𝒢"
  by (auto simp: agtt_only_reach_lang)

lemma gtt_only_reach_syms:
  "gtt_syms (gtt_only_reach 𝒢) |⊆| gtt_syms 𝒢"
  by (auto simp: gtt_only_reach_def ta_restrict_def ta_sig_def)

subsection ‹(A)GTT productive states›

definition gtt_only_prod where
  "gtt_only_prod 𝒢 = (let iface = gtt_interface 𝒢 in
     map_both (ta_only_prod iface) 𝒢)"

lemma agtt_only_prod_lang:
  "agtt_lang (gtt_only_prod 𝒢) = agtt_lang 𝒢" (is "?Ls = ?Rs")
proof -
  let ?A = "fst 𝒢" let ?B = "snd 𝒢"
  have "?Ls ⊆ ?Rs" unfolding agtt_lang_def gtt_only_prod_def
    by (auto simp: Let_def gta_der_def dest: ta_der_ta_only_prod_ta_der)
  moreover
  {fix s t assume "(s, t) ∈ ?Rs"
    then obtain q where r: "q |∈| ta_der (fst 𝒢) (term_of_gterm s)" "q |∈| ta_der (snd 𝒢) (term_of_gterm t)"
      by (auto simp: agtt_lang_def gta_der_def)
    then have " q |∈| gtt_interface 𝒢" by (auto simp: gtt_interface_def)
    then have "(s, t) ∈ ?Ls" using r
      by (auto simp: agtt_lang_def gta_der_def gtt_only_prod_def Let_def intro!: exI[of _ q] ta_der_only_prod ta_productive_setI)}
  ultimately show ?thesis by auto
qed
                   
lemma gtt_only_prod_lang:
  "gtt_lang (gtt_only_prod 𝒢) = gtt_lang 𝒢"
  by (auto simp: agtt_only_prod_lang)

lemma gtt_only_prod_syms:
  "gtt_syms (gtt_only_prod 𝒢) |⊆| gtt_syms 𝒢"
  by (auto simp: gtt_only_prod_def ta_restrict_def ta_sig_def Let_def)

subsection ‹(A)GTT trimming›

definition trim_gtt where
  "trim_gtt = gtt_only_prod ∘ gtt_only_reach"

lemma trim_agtt_lang:
  "agtt_lang (trim_gtt G) = agtt_lang G"
  unfolding trim_gtt_def comp_def agtt_only_prod_lang agtt_only_reach_lang ..

lemma trim_gtt_lang:
  "gtt_lang (trim_gtt G) = gtt_lang G"
  unfolding trim_gtt_def comp_def gtt_only_prod_lang gtt_only_reach_lang ..

lemma trim_gtt_prod_syms:
  "gtt_syms (trim_gtt G) |⊆| gtt_syms G"
  unfolding trim_gtt_def using fsubset_trans[OF gtt_only_prod_syms gtt_only_reach_syms] by simp

subsection ‹root-cleanliness›

text ‹A GTT is root-clean if none of its interface states can occur in a non-root positions
  in the accepting derivations corresponding to its anchored GTT relation.›

definition ta_nr_states :: "('q, 'f) ta ⇒ 'q fset" where
  "ta_nr_states A = |⋃| ((fset_of_list ∘ r_lhs_states) |`| (rules A))"

definition gtt_nr_states where
  "gtt_nr_states G = ta_nr_states (fst G) |∪| ta_nr_states (snd G)"

definition gtt_root_clean where
  "gtt_root_clean G ⟷ gtt_nr_states G |∩| gtt_interface G = {||}"


subsection ‹Relabeling›

definition relabel_gtt :: "('q :: linorder, 'f) gtt ⇒ (nat, 'f) gtt" where
  "relabel_gtt G = fmap_states_gtt (map_fset_to_nat (gtt_states G)) G"

lemma relabel_agtt_lang [simp]:
  "agtt_lang (relabel_gtt G) = agtt_lang G"
  by (simp add: agtt_lang_fmap_states_gtt map_fset_to_nat_inj relabel_gtt_def)

lemma agtt_lang_sig:
  "fset (gtt_syms G) ⊆ ℱ ⟹ agtt_lang G ⊆ 𝒯G ℱ × 𝒯G ℱ"
  by (auto simp: agtt_lang_def gta_der_def 𝒯G_equivalent_def)
     (metis ffunas_gterm.rep_eq less_eq_fset.rep_eq subset_iff ta_der_gterm_sig)+

subsection ‹epsilon free GTTs›


lemma agtt_lang_gtt_eps_free [simp]:
  "agtt_lang (gtt_eps_free 𝒢) = agtt_lang 𝒢"
  by (auto simp: agtt_lang_def gta_der_def gtt_eps_free_def ta_res_eps_free)

lemma gtt_lang_gtt_eps_free [simp]:
  "gtt_lang (gtt_eps_free 𝒢) = gtt_lang 𝒢"
  by auto

end
y>

Theory GTT_Compose

theory GTT_Compose
  imports GTT
begin

subsection ‹GTT closure under composition›

inductive_set Δε_set :: "('q, 'f) ta ⇒ ('q, 'f) ta ⇒ ('q × 'q) set" for 𝒜 ℬ where
  Δε_set_cong: "TA_rule f ps p |∈| rules 𝒜 ⟹ TA_rule f qs q |∈| rules ℬ ⟹ length ps = length qs ⟹
   (⋀i. i < length qs ⟹ (ps ! i, qs ! i) ∈ Δε_set 𝒜 ℬ) ⟹ (p, q) ∈ Δε_set 𝒜 ℬ"
| Δε_set_eps1: "(p, p') |∈| eps 𝒜 ⟹ (p, q) ∈ Δε_set 𝒜 ℬ ⟹ (p', q) ∈ Δε_set 𝒜 ℬ"
| Δε_set_eps2: "(q, q') |∈| eps ℬ ⟹ (p, q) ∈ Δε_set 𝒜 ℬ ⟹ (p, q') ∈ Δε_set 𝒜 ℬ"

lemma Δε_states: "Δε_set 𝒜 ℬ ⊆ fset (𝒬 𝒜 |×| 𝒬 ℬ)"
proof -
  {fix p q assume "(p, q) ∈ Δε_set 𝒜 ℬ" then have "(p, q) ∈ fset (𝒬 𝒜 |×| 𝒬 ℬ)"
      by (induct) (auto dest: rule_statesD eps_statesD simp flip: fmember.rep_eq)}
  then show ?thesis by auto
qed

lemma finite_Δε [simp]: "finite (Δε_set 𝒜 ℬ)"
  using finite_subset[OF Δε_states]
  by simp

context
includes fset.lifting
begin
lift_definition Δε :: "('q, 'f) ta ⇒ ('q, 'f) ta ⇒ ('q × 'q) fset" is Δε_set by simp
lemmas Δε_cong = Δε_set_cong [Transfer.transferred]
lemmas Δε_eps1 = Δε_set_eps1 [Transfer.transferred]
lemmas Δε_eps2 = Δε_set_eps2 [Transfer.transferred]
lemmas Δε_cases = Δε_set.cases[Transfer.transferred]
lemmas Δε_induct [consumes 1, case_names Δε_cong Δε_eps1  Δε_eps2] = Δε_set.induct[Transfer.transferred]
lemmas Δε_intros = Δε_set.intros[Transfer.transferred]
lemmas Δε_simps = Δε_set.simps[Transfer.transferred]
end

lemma finite_alt_def [simp]:
  "finite {(α, β). (∃t. ground t ∧ α |∈| ta_der 𝒜 t ∧ β |∈| ta_der ℬ t)}" (is "finite ?S")
  by (auto dest: ground_ta_der_states[THEN fsubsetD] simp flip: fmember.rep_eq
           intro!: finite_subset[of ?S "fset (𝒬 𝒜 |×| 𝒬 ℬ)"])

lemma Δε_def':
  "Δε 𝒜 ℬ = {|(α, β). (∃t. ground t ∧ α |∈| ta_der 𝒜 t ∧ β |∈| ta_der ℬ t)|}"
proof (intro fset_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x [simp]: "x = (p, q)" by (cases x)
  have "∃t. ground t ∧ p |∈| ta_der 𝒜 t ∧ q |∈| ta_der ℬ t" using lr unfolding x
  proof (induct rule: Δε_induct)
    case (Δε_cong f ps p qs q)
    obtain ts where ts: "ground (ts i) ∧ ps ! i |∈| ta_der 𝒜 (ts i) ∧ qs ! i |∈| ta_der ℬ (ts i)"
      if "i < length qs" for i using Δε_cong(5) by metis
    then show ?case using Δε_cong(1-3)
      by (auto intro!: exI[of _ "Fun f (map ts [0..<length qs])"]) blast+
  qed (meson ta_der_eps)+
  then show ?case by auto
next
  case (rl x) obtain p q where x [simp]: "x = (p, q)" by (cases x)
  obtain t where "ground t" "p |∈| ta_der 𝒜 t" "q |∈| ta_der ℬ t" using rl by auto
  then show ?case unfolding x
  proof (induct t arbitrary: p q)
    case (Fun f ts)
    obtain p' ps where p': "TA_rule f ps p' |∈| rules 𝒜" "p' = p ∨ (p', p) |∈| (eps 𝒜)|+|" "length ps = length ts"
      "⋀i. i < length ts ⟹ ps ! i |∈| ta_der 𝒜 (ts ! i)" using Fun(3) by auto
    obtain q' qs where q': "f qs → q' |∈| rules ℬ" "q' = q ∨ (q', q) |∈| (eps ℬ)|+|" "length qs = length ts"
      "⋀i. i < length ts ⟹ qs ! i |∈| ta_der ℬ (ts ! i)" using Fun(4) by auto
    have st: "(p', q') |∈| Δε 𝒜 ℬ"
      using Fun(1)[OF nth_mem _ p'(4) q'(4)] Fun(2) p'(3) q'(3)
      by (intro Δε_cong[OF p'(1) q'(1)]) auto
    {assume "(p', p) |∈| (eps 𝒜)|+|" then have "(p, q') |∈| Δε 𝒜 ℬ" using st
        by (induct rule: ftrancl_induct) (auto intro: Δε_eps1)}
    from st this p'(2) have st: "(p, q') |∈| Δε 𝒜 ℬ" by auto
   {assume "(q', q) |∈| (eps ℬ)|+|" then have "(p, q) |∈| Δε 𝒜 ℬ" using st
        by (induct rule: ftrancl_induct) (auto intro: Δε_eps2)}
    from st this q'(2) show "(p, q) |∈| Δε 𝒜 ℬ" by auto
  qed auto
qed

lemma Δε_fmember:
  "(p, q) |∈| Δε 𝒜 ℬ ⟷ (∃t. ground t ∧ p |∈| ta_der 𝒜 t ∧ q |∈| ta_der ℬ t)"
  by (auto simp: Δε_def')

definition GTT_comp :: "('q, 'f) gtt ⇒ ('q, 'f) gtt ⇒ ('q, 'f) gtt" where
  "GTT_comp 𝒢1 𝒢2 =
    (let Δ = Δε (snd 𝒢1) (fst 𝒢2) in
    (TA (gtt_rules (fst 𝒢1, fst 𝒢2)) (eps (fst 𝒢1) |∪| eps (fst 𝒢2) |∪| Δ),
     TA (gtt_rules (snd 𝒢1, snd 𝒢2)) (eps (snd 𝒢1) |∪| eps (snd 𝒢2) |∪| (Δ|¯|))))"

lemma gtt_syms_GTT_comp:
  "gtt_syms (GTT_comp A B) = gtt_syms A |∪| gtt_syms B"
  by (auto simp: GTT_comp_def ta_sig_def Let_def)

lemma Δε_statesD:
  "(p, q) |∈| Δε 𝒜 ℬ ⟹ p |∈| 𝒬 𝒜"
  "(p, q) |∈| Δε 𝒜 ℬ ⟹ q |∈| 𝒬 ℬ"
  using subsetD[OF Δε_states, of "(p, q)" 𝒜 ℬ]
  by (auto simp flip: Δε.rep_eq fmember.rep_eq)

lemma Δε_statesD':
  "q |∈| eps_states (Δε 𝒜 ℬ) ⟹ q |∈| 𝒬 𝒜 |∪| 𝒬 ℬ"
  by (auto simp: eps_states_def fmember.abs_eq dest: Δε_statesD)

lemma Δε_swap:
  "prod.swap p |∈| Δε 𝒜 ℬ ⟷ p |∈| Δε ℬ 𝒜"
  by (auto simp: Δε_def')

lemma Δε_inverse [simp]:
  "(Δε 𝒜 ℬ)|¯| = Δε ℬ 𝒜"
  by (auto simp: Δε_def')


lemma gtt_states_comp_union:
  "gtt_states (GTT_comp 𝒢1 𝒢2) |⊆| gtt_states 𝒢1 |∪| gtt_states 𝒢2"
proof (intro fsubsetI, goal_cases lr)
  case (lr q) then show ?case
    by (auto simp: GTT_comp_def gtt_states_def 𝒬_def dest: Δε_statesD')
qed

lemma GTT_comp_swap [simp]:
  "GTT_comp (prod.swap 𝒢2) (prod.swap 𝒢1) = prod.swap (GTT_comp 𝒢1 𝒢2)"
  by (simp add: GTT_comp_def ac_simps)

lemma gtt_comp_complete_semi:
  assumes s: "q |∈| gta_der (fst 𝒢1) s" and u: "q |∈| gta_der (snd 𝒢1) u" and ut: "gtt_accept 𝒢2 u t"
  shows "q |∈| gta_der (fst (GTT_comp 𝒢1 𝒢2)) s" "q |∈| gta_der (snd (GTT_comp 𝒢1 𝒢2)) t"
proof (goal_cases L R)
  let ?𝒢 = "GTT_comp 𝒢1 𝒢2"
  have  sub1l: "rules (fst 𝒢1) |⊆| rules (fst ?𝒢)" "eps (fst 𝒢1) |⊆| eps (fst ?𝒢)"
    and sub1r: "rules (snd 𝒢1) |⊆| rules (snd ?𝒢)" "eps (snd 𝒢1) |⊆| eps (snd ?𝒢)" 
    and sub2r: "rules (snd 𝒢2) |⊆| rules (snd ?𝒢)" "eps (snd 𝒢2) |⊆| eps (snd ?𝒢)"
    by (auto simp: GTT_comp_def)
  { case L then show ?case using s ta_der_mono[OF sub1l]
      by (auto simp: gta_der_def)
  next
    case R then show ?case using ut u unfolding gtt_accept_def
    proof (induct arbitrary: q s)
      case (base s t)
      from base(1) obtain p where p: "p |∈| gta_der (fst 𝒢2) s" "p |∈| gta_der (snd 𝒢2) t"
        by (auto simp: agtt_lang_def)
      then have "(p, q) |∈| eps (snd (GTT_comp 𝒢1 𝒢2))"
        using Δε_fmember[of p q "fst 𝒢2" "snd 𝒢1"] base(2)
        by (auto simp: GTT_comp_def gta_der_def)
      from ta_der_eps[OF this] show ?case using p ta_der_mono[OF sub2r]
        by (auto simp add: gta_der_def)
    next
      case (step ss ts f)
      from step(1, 4) obtain ps p where "TA_rule f ps p |∈| rules (snd 𝒢1)" "p = q ∨ (p, q) |∈| (eps (snd 𝒢1))|+|"
        "length ps = length ts" "⋀i. i < length ts ⟹ ps ! i |∈| gta_der (snd 𝒢1) (ss ! i)"
        unfolding gta_der_def by auto
      then show ?case using step(1, 2) sub1r(1) ftrancl_mono[OF _ sub1r(2)]
        by (auto simp: gta_der_def intro!: exI[of _ p] exI[of _ ps])
    qed}
qed

lemmas gtt_comp_complete_semi' = gtt_comp_complete_semi[of _ "prod.swap 𝒢2" _ _ "prod.swap 𝒢1" for 𝒢1 𝒢2,
  unfolded fst_swap snd_swap GTT_comp_swap gtt_accept_swap]

lemma gtt_comp_acomplete:
  "gcomp_rel UNIV (agtt_lang 𝒢1) (agtt_lang 𝒢2) ⊆ agtt_lang (GTT_comp 𝒢1 𝒢2)"
proof (intro subrelI, goal_cases LR)
  case (LR s t)
  then consider
      q u where "q |∈| gta_der (fst 𝒢1) s" "q |∈| gta_der (snd 𝒢1) u" "gtt_accept 𝒢2 u t"
    | q u where "q |∈| gta_der (snd 𝒢2) t" "q |∈| gta_der (fst 𝒢2) u" "gtt_accept 𝒢1 s u"
    by (auto simp: gcomp_rel_def gtt_accept_def elim!: agtt_langE)
  then show ?case
  proof (cases)
    case 1 show ?thesis using gtt_comp_complete_semi[OF 1]
      by (auto simp: agtt_lang_def gta_der_def)
  next
    case 2 show ?thesis using gtt_comp_complete_semi'[OF 2]
      by (auto simp: agtt_lang_def gta_der_def)
  qed
qed

lemma Δε_steps_from_𝒢2:
  assumes "(q, q') |∈| (eps (fst (GTT_comp 𝒢1 𝒢2)))|+|" "q |∈| gtt_states 𝒢2"
    "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "(q, q') |∈| (eps (fst 𝒢2))|+| ∧ q' |∈| gtt_states 𝒢2"
  using assms(1-2)
proof (induct rule: converse_ftrancl_induct)
  case (Base y)
  then show ?case using assms(3)
    by (fastforce simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD Δε_statesD(1))
next
  case (Step q p)
  have "(q, p) |∈| (eps (fst 𝒢2))|+|" "p |∈| gtt_states 𝒢2"
    using Step(1, 4) assms(3)
    by (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD Δε_statesD(1))
  then show ?case using Step(3)
    by (auto intro: ftrancl_trans)
qed

lemma Δε_steps_from_𝒢1:
  assumes "(p, r) |∈| (eps (fst (GTT_comp 𝒢1 𝒢2)))|+|" "p |∈| gtt_states 𝒢1"
    "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  obtains "r |∈| gtt_states 𝒢1" "(p, r) |∈| (eps (fst 𝒢1))|+|"
  | q p' where "r |∈| gtt_states 𝒢2" "p = p' ∨ (p, p') |∈| (eps (fst 𝒢1))|+|" "(p', q) |∈| Δε (snd 𝒢1) (fst 𝒢2)"
    "q = r ∨ (q, r) |∈| (eps (fst 𝒢2))|+|"
  using assms(1,2)
proof (induct arbitrary: thesis rule: converse_ftrancl_induct)
  case (Base p)
  from Base(1) consider (a) "(p, r) |∈| eps (fst 𝒢1)" | (b) "(p, r) |∈| eps (fst 𝒢2)" |
    (c) "(p, r) |∈| (Δε (snd 𝒢1) (fst 𝒢2))"
    by (auto simp: GTT_comp_def fmember.abs_eq)
  then show ?case using assms(3) Base
    by cases (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD Δε_statesD)
next
  case (Step q p)
  consider "(q, p) |∈| (eps (fst 𝒢1))|+|" "p |∈| gtt_states 𝒢1"
    | "(q, p) |∈| Δε (snd 𝒢1) (fst 𝒢2)" "p |∈| gtt_states 𝒢2" using assms(3) Step(1, 6)
    by (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD Δε_statesD)
  then show ?case
  proof (cases)
    case 1 note a = 1 show ?thesis
    proof (cases rule: Step(3))
      case (2 p' q)
      then show ?thesis using assms a
        by (auto intro: Step(5) ftrancl_trans)
    qed (auto simp: a(2) intro: Step(4) ftrancl_trans[OF a(1)])
  next
    case 2 show ?thesis using Δε_steps_from_𝒢2[OF Step(2) 2(2) assms(3)] Step(5)[OF _ _ 2(1)] by auto
  qed
qed

lemma Δε_steps_from_𝒢1_𝒢2:
  assumes "(q, q') |∈| (eps (fst (GTT_comp 𝒢1 𝒢2)))|+|" "q |∈| gtt_states 𝒢1 |∪| gtt_states 𝒢2"
    "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  obtains "q |∈| gtt_states 𝒢1" "q' |∈| gtt_states 𝒢1" "(q, q') |∈| (eps (fst 𝒢1))|+|"
  | p p' where "q |∈| gtt_states 𝒢1" "q' |∈| gtt_states 𝒢2" "q = p ∨ (q, p) |∈| (eps (fst 𝒢1))|+|"
    "(p, p') |∈| Δε (snd 𝒢1) (fst 𝒢2)" "p' = q' ∨ (p', q') |∈| (eps (fst 𝒢2))|+|"
  | "q |∈| gtt_states 𝒢2" "(q, q') |∈| (eps (fst 𝒢2))|+| ∧ q' |∈| gtt_states 𝒢2"
  using assms Δε_steps_from_𝒢1 Δε_steps_from_𝒢2
  by (metis funion_iff)

lemma GTT_comp_eps_fst_statesD:
  "(p, q) |∈| eps (fst (GTT_comp 𝒢1 𝒢2)) ⟹ p |∈| gtt_states 𝒢1 |∪| gtt_states 𝒢2"
  "(p, q) |∈| eps (fst (GTT_comp 𝒢1 𝒢2)) ⟹ q |∈| gtt_states 𝒢1 |∪| gtt_states 𝒢2"
  by (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD Δε_statesD)

lemma GTT_comp_eps_ftrancl_fst_statesD:
  "(p, q) |∈| (eps (fst (GTT_comp 𝒢1 𝒢2)))|+| ⟹ p |∈| gtt_states 𝒢1 |∪| gtt_states 𝒢2"
  "(p, q) |∈| (eps (fst (GTT_comp 𝒢1 𝒢2)))|+| ⟹ q |∈| gtt_states 𝒢1 |∪| gtt_states 𝒢2"
  using GTT_comp_eps_fst_statesD[of _ _ 𝒢1 𝒢2]
  by (meson converse_ftranclE ftranclE)+

lemma GTT_comp_first:
  assumes "q |∈| ta_der (fst (GTT_comp 𝒢1 𝒢2)) t" "q |∈| gtt_states 𝒢1"
    "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "q |∈| ta_der (fst 𝒢1) t"
  using assms(1,2)
proof (induct t arbitrary: q)
  case (Var q')
  have "q ≠ q' ⟹ q' |∈| gtt_states 𝒢1 |∪| gtt_states 𝒢2" using Var
    by (auto dest: GTT_comp_eps_ftrancl_fst_statesD)
  then show ?case using Var assms(3)
    by (auto elim: Δε_steps_from_𝒢1_𝒢2)
next
  case (Fun f ts)
  obtain q' qs where q': "TA_rule f qs q' |∈| rules (fst (GTT_comp 𝒢1 𝒢2))"
    "q' = q ∨ (q', q) |∈| (eps (fst (GTT_comp 𝒢1 𝒢2)))|+|" "length qs = length ts"
    "⋀i. i < length ts ⟹ qs ! i |∈| ta_der (fst (GTT_comp 𝒢1 𝒢2)) (ts ! i)"
    using Fun(2) by auto
  have "q' |∈| gtt_states 𝒢1 |∪| gtt_states 𝒢2" using q'(1)
    by (auto simp: GTT_comp_def gtt_states_def dest: rule_statesD)
  then have st: "q' |∈| gtt_states 𝒢1" and eps:"q' = q ∨ (q', q) |∈| (eps (fst 𝒢1))|+|"
    using q'(2) Fun(3) assms(3)
    by (auto elim!: Δε_steps_from_𝒢1_𝒢2)
  from st have rule: "TA_rule f qs q' |∈| rules (fst 𝒢1)" using assms(3) q'(1)
    by (auto simp: GTT_comp_def gtt_states_def dest: rule_statesD)
  have "i < length ts ⟹ qs ! i |∈| ta_der (fst 𝒢1) (ts ! i)" for i
    using rule q'(3, 4)
    by (intro Fun(1)[OF nth_mem]) (auto simp: gtt_states_def dest!: rule_statesD(4))
  then show ?case using q'(3) rule eps
    by auto
qed

lemma GTT_comp_second:
  assumes "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}" "q |∈| gtt_states 𝒢2"
    "q |∈| ta_der (snd (GTT_comp 𝒢1 𝒢2)) t"
  shows "q |∈| ta_der (snd 𝒢2) t"
  using assms GTT_comp_first[of q "prod.swap 𝒢2" "prod.swap 𝒢1"]
  by (auto simp: gtt_states_def)

lemma gtt_comp_sound_semi:
  fixes 𝒢1 𝒢2 :: "('f, 'q) gtt"
  assumes as2: "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  and 1: "q |∈| gta_der (fst (GTT_comp 𝒢1 𝒢2)) s" "q |∈| gta_der (snd (GTT_comp 𝒢1 𝒢2)) t" "q |∈| gtt_states 𝒢1"
  shows "∃u. q |∈| gta_der (snd 𝒢1) u ∧ gtt_accept 𝒢2 u t" using 1(2,3) unfolding gta_der_def
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  show ?case
  proof (cases "p |∈| gtt_states 𝒢1")
    case True
    then have *: "TA_rule f ps p |∈| rules (snd 𝒢1)" using GFun(1, 6) as2
      by (auto simp: GTT_comp_def gtt_states_def dest: rule_statesD)
    moreover have st: "i < length ps ⟹ ps ! i |∈| gtt_states 𝒢1" for i using *
      by (force simp: gtt_states_def dest: rule_statesD)
    moreover have "i < length ps ⟹ ∃u. ps ! i |∈| ta_der (snd 𝒢1) (term_of_gterm u) ∧ gtt_accept 𝒢2 u (ts ! i)" for i
      using st GFun(2) by (intro GFun(5)) simp
    then obtain us where
      "⋀i. i < length ps ⟹ ps ! i |∈| ta_der (snd 𝒢1) (term_of_gterm (us i)) ∧ gtt_accept 𝒢2 (us i) (ts ! i)"
      by metis
    moreover have "p = q ∨ (p, q) |∈| (eps (snd 𝒢1))|+|" using GFun(3, 6) True as2
      by (auto simp: gtt_states_def  elim!: Δε_steps_from_𝒢1_𝒢2[of p q "prod.swap 𝒢2" "prod.swap 𝒢1", simplified])
    ultimately show ?thesis using GFun(2)
      by (intro exI[of _ "GFun f (map us [0..<length ts])"])
         (auto simp: gtt_accept_def intro!: exI[of _ ps] exI[of _ p])
  next
    case False note nt_st = this
    then have False: "p ≠ q" using GFun(6) by auto
    then have eps: "(p, q) |∈| (eps (snd (GTT_comp 𝒢1 𝒢2)))|+|" using GFun(3) by simp
    show ?thesis using Δε_steps_from_𝒢1_𝒢2[of p q "prod.swap 𝒢2" "prod.swap 𝒢1", simplified, OF eps]
    proof (cases, goal_cases)
      case 1 then show ?case using False GFun(3)
        by (metis GTT_comp_eps_ftrancl_fst_statesD(1) GTT_comp_swap fst_swap funion_iff)
    next
      case 2 then show ?case using as2 by (auto simp: gtt_states_def)
    next
      case 3 then show ?case using as2 GFun(6) by (auto simp: gtt_states_def)
    next
      case (4 r p')
      have meet: "r |∈| ta_der (snd (GTT_comp 𝒢1 𝒢2)) (Fun f (map term_of_gterm ts))"
        using GFun(1 - 4) 4(3) False
        by (auto simp: GTT_comp_def in_ftrancl_UnI intro!: exI[ of _ ps] exI[ of _ p])
      then obtain u where wit: "ground u" "p' |∈| ta_der (snd 𝒢1) u" "r |∈| ta_der (fst 𝒢2) u"
        using 4(4-) unfolding Δε_def' by blast
      from wit(1, 3) have "gtt_accept 𝒢2 (gterm_of_term u) (GFun f ts)"
        using GTT_comp_second[OF as2 _ meet] unfolding gtt_accept_def
        by (intro gmctxt_cl.base agtt_langI[of r])
           (auto simp add: gta_der_def gtt_states_def simp del: ta_der_Fun dest: ground_ta_der_states)
      then show ?case using 4(5) wit(1, 2)
        by (intro exI[of _ "gterm_of_term u"]) (auto simp add: ta_der_trancl_eps)
    next
      case 5
      then show ?case using nt_st as2
        by (simp add: gtt_states_def)  
    qed
  qed
qed

lemma gtt_comp_asound:
  assumes "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "agtt_lang (GTT_comp 𝒢1 𝒢2) ⊆ gcomp_rel UNIV (agtt_lang 𝒢1) (agtt_lang 𝒢2)"
proof (intro subrelI, goal_cases LR)
  case (LR s t)
  obtain q where q: "q |∈| gta_der (fst (GTT_comp 𝒢1 𝒢2)) s" "q |∈| gta_der (snd (GTT_comp 𝒢1 𝒢2)) t"
    using LR by (auto simp: agtt_lang_def)
  { (* prepare symmetric cases: q |∈| gtt_states 𝒢1 and q |∈| gtt_states 𝒢2 *)
    fix 𝒢1 𝒢2 s t assume as2: "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
      and 1: "q |∈| ta_der (fst (GTT_comp 𝒢1 𝒢2)) (term_of_gterm s)"
        "q |∈| ta_der (snd (GTT_comp 𝒢1 𝒢2)) (term_of_gterm t)" "q |∈| gtt_states 𝒢1"
    note st = GTT_comp_first[OF 1(1,3) as2]
    obtain u where u: "q |∈| ta_der (snd 𝒢1) (term_of_gterm u)" "gtt_accept 𝒢2 u t"
      using gtt_comp_sound_semi[OF as2 1[folded gta_der_def]] by (auto simp: gta_der_def)
    have "(s, u) ∈ agtt_lang 𝒢1" using st u(1)
      by (auto simp: agtt_lang_def gta_der_def)
    moreover have "(u, t) ∈ gtt_lang 𝒢2" using u(2)
      by (auto simp: gtt_accept_def)
    ultimately have "(s, t) ∈ agtt_lang 𝒢1 O gmctxt_cl UNIV (agtt_lang 𝒢2)"
      by auto}
  note base = this
  consider "q |∈| gtt_states 𝒢1" | "q |∈| gtt_states 𝒢2" | "q |∉| gtt_states 𝒢1 |∪| gtt_states 𝒢2" by blast
  then show ?case using q assms
  proof (cases, goal_cases)
    case 1 then show ?case using base[of 𝒢1 𝒢2 s t]
      by (auto simp: gcomp_rel_def gta_der_def)
  next
    case 2 then show ?case using base[of "prod.swap 𝒢2" "prod.swap 𝒢1" t s, THEN converseI]
      by (auto simp: gcomp_rel_def converse_relcomp converse_agtt_lang gta_der_def gtt_states_def)
         (simp add: finter_commute funion_commute gtt_lang_swap prod.swap_def)+
  next
    case 3 then show ?case using fsubsetD[OF gtt_states_comp_union[of 𝒢1 𝒢2], of q]
      by (auto simp: gta_der_def gtt_states_def)
  qed
qed

lemma gtt_comp_lang_complete:
  shows "gtt_lang 𝒢1 O gtt_lang 𝒢2 ⊆ gtt_lang (GTT_comp 𝒢1 𝒢2)"
  using gmctxt_cl_mono_rel[OF gtt_comp_acomplete, of UNIV 𝒢1 𝒢2]
  by (simp only: gcomp_rel[symmetric])

lemma gtt_comp_alang:
  assumes "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "agtt_lang (GTT_comp 𝒢1 𝒢2) = gcomp_rel UNIV (agtt_lang 𝒢1) (agtt_lang 𝒢2)"
  by (intro equalityI gtt_comp_asound[OF assms] gtt_comp_acomplete)

lemma gtt_comp_lang:
  assumes "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "gtt_lang (GTT_comp 𝒢1 𝒢2) = gtt_lang 𝒢1 O gtt_lang 𝒢2"
  by (simp only: arg_cong[OF gtt_comp_alang[OF assms], of "gmctxt_cl UNIV"] gcomp_rel)

abbreviation GTT_comp' where
  "GTT_comp' 𝒢1 𝒢2 ≡ GTT_comp (fmap_states_gtt Inl 𝒢1) (fmap_states_gtt Inr 𝒢2)"

lemma gtt_comp'_alang:
  shows "agtt_lang (GTT_comp' 𝒢1 𝒢2) = gcomp_rel UNIV (agtt_lang 𝒢1) (agtt_lang 𝒢2)"
proof -
  have [simp]: "finj_on Inl (gtt_states 𝒢1)" "finj_on Inr (gtt_states 𝒢2)"
    by (auto simp add: finj_on.rep_eq)
  then show ?thesis                                        
    by (subst gtt_comp_alang) (auto simp: agtt_lang_fmap_states_gtt)
qed

end
ead>

Theory GTT_Transitive_Closure

theory GTT_Transitive_Closure
  imports GTT_Compose
begin

subsection ‹GTT closure under transitivity›

inductive_set Δ_trancl_set :: "('q, 'f) ta ⇒ ('q, 'f) ta ⇒ ('q × 'q) set" for A B where
  Δ_set_cong: "TA_rule f ps p |∈| rules A ⟹ TA_rule f qs q |∈| rules B ⟹ length ps = length qs ⟹
   (⋀i. i < length qs ⟹ (ps ! i, qs ! i) ∈ Δ_trancl_set A B) ⟹ (p, q) ∈ Δ_trancl_set A B"
| Δ_set_eps1: "(p, p') |∈| eps A ⟹ (p, q) ∈ Δ_trancl_set A B ⟹ (p', q) ∈ Δ_trancl_set A B"
| Δ_set_eps2: "(q, q') |∈| eps B ⟹ (p, q) ∈ Δ_trancl_set A B ⟹ (p, q') ∈ Δ_trancl_set A B"
| Δ_set_trans: "(p, q) ∈ Δ_trancl_set A B ⟹ (q, r) ∈ Δ_trancl_set A B ⟹ (p, r) ∈ Δ_trancl_set A B"

lemma Δ_trancl_set_states: "Δ_trancl_set 𝒜 ℬ ⊆ fset (𝒬 𝒜 |×| 𝒬 ℬ)"
proof -
  {fix p q assume "(p, q) ∈ Δ_trancl_set 𝒜 ℬ" then have "(p, q) ∈ fset (𝒬 𝒜 |×| 𝒬 ℬ)"
      by (induct) (auto dest: rule_statesD eps_statesD simp flip: fmember.rep_eq)}
  then show ?thesis by auto
qed

lemma finite_Δ_trancl_set [simp]: "finite (Δ_trancl_set 𝒜 ℬ)"
  using finite_subset[OF Δ_trancl_set_states]
  by simp

context
includes fset.lifting
begin
lift_definition Δ_trancl :: "('q, 'f) ta ⇒ ('q, 'f) ta ⇒ ('q × 'q) fset" is Δ_trancl_set by simp
lemmas Δ_trancl_cong = Δ_set_cong [Transfer.transferred]
lemmas Δ_trancl_eps1 = Δ_set_eps1 [Transfer.transferred]
lemmas Δ_trancl_eps2 = Δ_set_eps2 [Transfer.transferred]
lemmas Δ_trancl_cases = Δ_trancl_set.cases[Transfer.transferred]
lemmas Δ_trancl_induct [consumes 1, case_names Δ_cong Δ_eps1 Δ_eps2 Δ_trans] = Δ_trancl_set.induct[Transfer.transferred]
lemmas Δ_trancl_intros = Δ_trancl_set.intros[Transfer.transferred]
lemmas Δ_trancl_simps = Δ_trancl_set.simps[Transfer.transferred]
end


lemma Δ_trancl_cl [simp]:
  "(Δ_trancl A B)|+| = Δ_trancl A B"
proof -
  {fix s t assume "(s, t) |∈| (Δ_trancl A B)|+|" then have "(s, t) |∈| Δ_trancl A B"
      by (induct rule: ftrancl_induct) (auto intro: Δ_trancl_intros)}
  then show ?thesis by auto
qed

lemma Δ_trancl_states: "Δ_trancl 𝒜 ℬ |⊆| (𝒬 𝒜 |×| 𝒬 ℬ)"
  using Δ_trancl_set_states
  by (metis Δ_trancl.rep_eq fSigma_cong less_eq_fset.rep_eq)

definition GTT_trancl where
  "GTT_trancl G =
    (let Δ = Δ_trancl (snd G) (fst G) in
    (TA (rules (fst G)) (eps (fst G) |∪| Δ),
                   TA (rules (snd G)) (eps (snd G) |∪| (Δ|¯|))))"

lemma Δ_trancl_inv:
  "(Δ_trancl A B)|¯| = Δ_trancl B A"
proof -
  have [dest]: "(p, q) |∈| Δ_trancl A B ⟹ (q, p) |∈| Δ_trancl B A" for p q A B
    by (induct rule: Δ_trancl_induct) (auto intro: Δ_trancl_intros)
  show ?thesis by auto
qed

lemma gtt_states_GTT_trancl:
  "gtt_states (GTT_trancl G) |⊆| gtt_states G"
  unfolding GTT_trancl_def
  by (auto simp: gtt_states_def 𝒬_def Δ_trancl_inv dest!: fsubsetD[OF Δ_trancl_states] simp flip: fmember.rep_eq)

lemma gtt_syms_GTT_trancl:
  "gtt_syms (GTT_trancl G) = gtt_syms G"
  by (auto simp: GTT_trancl_def ta_sig_def Δ_trancl_inv)

lemma GTT_trancl_base:
  "gtt_lang G ⊆ gtt_lang (GTT_trancl G)"
  using gtt_lang_mono[of G "GTT_trancl G"] by (auto simp: Δ_trancl_inv GTT_trancl_def)

lemma GTT_trancl_trans:
  "gtt_lang (GTT_comp (GTT_trancl G) (GTT_trancl G)) ⊆ gtt_lang (GTT_trancl G)"
proof -
  have [dest]: "(p, q) |∈| Δε (TA (rules A) (eps A |∪| (Δ_trancl B A)))
    (TA (rules B) (eps B |∪| (Δ_trancl A B))) ⟹ (p, q) |∈| Δ_trancl A B" for p q A B
    by (induct rule: Δε_induct) (auto intro: Δ_trancl_intros simp: Δ_trancl_inv[of B A, symmetric])
  show ?thesis
    by (intro gtt_lang_mono[of "GTT_comp (GTT_trancl G) (GTT_trancl G)" "GTT_trancl G"])
       (auto simp: GTT_comp_def GTT_trancl_def fmember.abs_eq Δ_trancl_inv)
qed

lemma agtt_lang_base:
  "agtt_lang G ⊆ agtt_lang (GTT_trancl G)"
  by (rule agtt_lang_mono) (auto simp: GTT_trancl_def Δ_trancl_inv)


lemma Δε_tr_incl:
  "Δε (TA (rules A) (eps A |∪| Δ_trancl B A)) (TA (rules B)  (eps B |∪| Δ_trancl A B)) = Δ_trancl A B"
   (is "?LS = ?RS")
proof -
  {fix p q assume "(p, q) |∈| ?LS" then have "(p, q) |∈| ?RS"
      by (induct rule: Δε_induct)
         (auto simp: Δ_trancl_inv[of B A, symmetric] intro: Δ_trancl_intros)}
  moreover
  {fix p q assume "(p, q) |∈| ?RS" then have "(p, q) |∈| ?LS"
      by (induct rule: Δ_trancl_induct)
        (auto simp: Δ_trancl_inv[of B A, symmetric] intro: Δε_intros)}
  ultimately show ?thesis
    by auto
qed


lemma agtt_lang_trans:
  "gcomp_rel UNIV (agtt_lang (GTT_trancl G)) (agtt_lang (GTT_trancl G)) ⊆ agtt_lang (GTT_trancl G)"
proof -
  have [intro!, dest]: "(p, q) |∈| Δε (TA (rules A) (eps A |∪| (Δ_trancl B A)))
    (TA (rules B) (eps B |∪| (Δ_trancl A B))) ⟹ (p, q) |∈| Δ_trancl A B" for p q A B
    by (induct rule: Δε_induct) (auto intro: Δ_trancl_intros simp: Δ_trancl_inv[of B A, symmetric])
  show ?thesis
    by (rule subset_trans[OF gtt_comp_acomplete agtt_lang_mono])
       (auto simp: GTT_comp_def GTT_trancl_def Δ_trancl_inv)
qed

lemma GTT_trancl_acomplete:
  "gtrancl_rel UNIV (agtt_lang G) ⊆ agtt_lang (GTT_trancl G)"
  unfolding gtrancl_rel_def
  using agtt_lang_base[of G] gmctxt_cl_mono_rel[OF agtt_lang_base[of G], of UNIV]
  using agtt_lang_trans[of G]
  unfolding gcomp_rel_def
  by (intro kleene_trancl_induct) blast+

lemma Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang:
  "(gtt_lang G)* = (gtt_lang G)+"
  by (auto simp: rtrancl_trancl_reflcl simp del: reflcl_trancl dest: tranclD tranclD2 intro: gmctxt_cl_refl)

lemma GTT_trancl_complete:
  "(gtt_lang G)+ ⊆ gtt_lang (GTT_trancl G)"
  using GTT_trancl_base subset_trans[OF gtt_comp_lang_complete GTT_trancl_trans]
  by (metis trancl_id trancl_mono_set trans_O_iff)

lemma trancl_gtt_lang_arg_closed:
  assumes "length ss = length ts" "∀i < length ts. (ss ! i, ts ! i) ∈ (gtt_lang 𝒢)+"
  shows "(GFun f ss, GFun f ts) ∈ (gtt_lang 𝒢)+" (is "?e ∈ _")
proof -
  have "all_ctxt_closed UNIV ((gtt_lang 𝒢)+)" by (intro all_ctxt_closed_trancl) auto
  from all_ctxt_closedD[OF this _ assms] show ?thesis
    by auto
qed

lemma Δ_trancl_sound:
  assumes "(p, q) |∈| Δ_trancl A B"
  obtains s t where "(s, t) ∈ (gtt_lang (B, A))+" "p |∈| gta_der A s" "q |∈| gta_der B t"
  using assms
proof (induct arbitrary: thesis rule: Δ_trancl_induct)
  case (Δ_cong f ps p qs q)
  have "∃si ti. (si, ti) ∈ (gtt_lang (B, A))+ ∧ ps ! i |∈| gta_der A (si) ∧
      qs ! i |∈| gta_der B (ti)" if "i < length qs" for i
    using Δ_cong(5)[OF that] by metis
  then obtain ss ts where
    "⋀i. i < length qs ⟹ (ss i, ts i) ∈ (gtt_lang (B, A))+ ∧ ps ! i |∈| gta_der A (ss i) ∧ qs ! i |∈| gta_der B (ts i)" by metis
  then show ?case using Δ_cong(1-5)
    by (intro Δ_cong(6)[of "GFun f (map ss [0..<length ps])" "GFun f (map ts [0..<length qs])"])
       (auto simp: gta_der_def intro!: trancl_gtt_lang_arg_closed)
next
  case (Δ_eps1 p p' q) then show ?case
    by (metis gta_der_def ta_der_eps)
next
  case (Δ_eps2 q q' p) then show ?case
    by (metis gta_der_def ta_der_eps)
next
  case (Δ_trans p q r)
  obtain s1 t1 where "(s1, t1) ∈ (gtt_lang (B, A))+" "p |∈| gta_der A s1" "q |∈| gta_der B t1"
    using Δ_trans(2) .note 1 = this
  obtain s2 t2 where "(s2, t2) ∈ (gtt_lang (B, A))+" "q |∈| gta_der A s2" "r |∈| gta_der B t2"
    using Δ_trans(4) . note 2 = this
  have "(t1, s2) ∈ gtt_lang (B, A)" using 1(1,3) 2(1,2)
    by (auto simp: Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang[symmetric] gtt_lang_join)
  then have "(s1, t2) ∈ (gtt_lang (B, A))+" using 1(1) 2(1)
    by (meson trancl.trancl_into_trancl trancl_trans)
  then show ?case using 1(2) 2(3) by (auto intro: Δ_trans(5)[of s1 t2])
qed

lemma GTT_trancl_sound_aux:
  assumes "p |∈| gta_der (TA (rules A) (eps A |∪| (Δ_trancl B A))) s"
  shows "∃t. (s, t) ∈ (gtt_lang (A, B))+ ∧ p |∈| gta_der A t"
  using assms
proof (induct s arbitrary: p)
  case (GFun f ss)
  let ?eps = "eps A |∪| Δ_trancl B A"
  obtain qs q where q: "TA_rule f qs q |∈| rules A" "q = p ∨ (q, p) |∈| ?eps|+|" "length qs = length ss"
   "⋀i. i < length ss ⟹ qs ! i |∈| gta_der (TA (rules A) ?eps) (ss ! i)"
    using GFun(2) by (auto simp: gta_der_def)
  have "⋀i. i < length ss ⟹ ∃ti. (ss ! i, ti) ∈ (gtt_lang (A, B))+ ∧ qs ! i |∈| gta_der A (ti)"
    using GFun(1)[OF nth_mem q(4)] unfolding gta_der_def by fastforce
  then obtain ts where ts: "⋀i. i < length ss ⟹ (ss ! i, ts i) ∈ (gtt_lang (A, B))+ ∧ qs ! i |∈| gta_der A (ts i)"
    by metis
  then have q': "q |∈| gta_der A (GFun f (map ts [0..<length ss]))"
    "(GFun f ss, GFun f (map ts [0..<length ss])) ∈ (gtt_lang (A, B))+" using q(1, 3)
    by (auto simp: gta_der_def intro!: exI[of _ qs] exI[of _ q] trancl_gtt_lang_arg_closed)
  {fix p q u assume ass: "(p, q) |∈| Δ_trancl B A" "(GFun f ss, u) ∈ (gtt_lang (A, B))+ ∧ p |∈| gta_der A u"
    from Δ_trancl_sound[OF this(1)] obtain s t
      where "(s, t) ∈ (gtt_lang (A, B))+" "p |∈| gta_der B s" "q |∈| gta_der A t" . note st = this
    have "(u, s) ∈ gtt_lang (A, B)" using st conjunct2[OF ass(2)]
      by (auto simp: Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang[symmetric] gtt_lang_join)
    then have "(GFun f ss, t) ∈ (gtt_lang (A, B))+"
      using ass st(1) by (meson trancl_into_trancl2 trancl_trans)
    then have "∃ s t. (GFun f ss, t) ∈ (gtt_lang (A, B))+ ∧ q |∈| gta_der A t" using st by blast}
  note trancl_step = this
  show ?case
  proof (cases "q = p")
    case True
    then show ?thesis using ts q(1, 3)
      by (auto simp: gta_der_def intro!: exI[of _"GFun f (map ts [0..< length ss])"] trancl_gtt_lang_arg_closed) blast
  next
    case False
    then have "(q, p) |∈| ?eps|+|" using q(2) by simp
    then show ?thesis using q(1) q'
    proof (induct rule: ftrancl_induct)
      case (Base q p) from Base(1) show ?case
      proof
        assume "(q, p) |∈| eps A" then show ?thesis using Base(2) ts q(3)
          by (auto simp: gta_der_def intro!: exI[of _"GFun f (map ts [0..< length ss])"]
                         trancl_gtt_lang_arg_closed exI[of _ qs] exI[of _ q])
      next
        assume "(q, p) |∈| (Δ_trancl B A)"
        then have "(q, p) |∈| Δ_trancl B A" by (simp add: fmember.abs_eq)       
        from trancl_step[OF this] show ?thesis using Base(3, 4)
          by auto
      qed
    next
      case (Step p q r)
      from Step(2, 4-) obtain s' where s': "(GFun f ss, s') ∈ (gtt_lang (A, B))+ ∧ q |∈| gta_der A s'" by auto
      show ?case using Step(3)
      proof
        assume "(q, r) |∈| eps A" then show ?thesis using s'
          by (auto simp: gta_der_def ta_der_eps intro!: exI[of _ s'])
      next
        assume "(q, r) |∈| Δ_trancl B A"
        then have "(q, r) |∈| Δ_trancl B A" by (simp add: fmember.abs_eq)       
        from trancl_step[OF this] show ?thesis using s' by auto
      qed
    qed
  qed
qed

lemma GTT_trancl_asound:
  "agtt_lang (GTT_trancl G) ⊆ gtrancl_rel UNIV (agtt_lang G)"
proof (intro subrelI, goal_cases LR)
  case (LR s t)
  then obtain s' q t' where *: "(s, s') ∈ (gtt_lang G)+"
    "q |∈| gta_der (fst G) s'" "q |∈| gta_der (snd G) t'" "(t', t) ∈ (gtt_lang G)+"
    by (auto simp: agtt_lang_def GTT_trancl_def trancl_converse Δ_trancl_inv
      simp flip: gtt_lang_swap[of "fst G" "snd G", unfolded prod.collapse agtt_lang_def, simplified]
      dest!: GTT_trancl_sound_aux)
  then have "(s', t') ∈ agtt_lang G" using *(2,3)
    by (auto simp: agtt_lang_def)
  then show ?case using *(1,4) unfolding gtrancl_rel_def
    by auto
qed

lemma GTT_trancl_sound:
  "gtt_lang (GTT_trancl G) ⊆ (gtt_lang G)+"
proof -
  note [dest] = GTT_trancl_sound_aux
  have "gtt_accept (GTT_trancl G) s t ⟹ (s, t) ∈ (gtt_lang G)+" for s t unfolding gtt_accept_def
  proof (induct rule: gmctxt_cl.induct)
    case (base s t)
    from base obtain q where join: "q |∈| gta_der (fst (GTT_trancl G)) s" "q |∈| gta_der (snd (GTT_trancl G)) t"
      by (auto simp: agtt_lang_def)
    obtain s' where "(s, s') ∈ (gtt_lang G)+" "q |∈| gta_der (fst G) s'" using base join
      by (auto simp: GTT_trancl_def Δ_trancl_inv agtt_lang_def)
    moreover obtain t' where "(t', t) ∈ (gtt_lang G)+" "q |∈| gta_der (snd G) t'" using join
      by (auto simp: GTT_trancl_def gtt_lang_swap[of "fst G" "snd G", symmetric] trancl_converse Δ_trancl_inv)
    moreover have "(s', t') ∈ gtt_lang G" using calculation
      by (auto simp: Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang[symmetric] gtt_lang_join)
    ultimately show "(s, t) ∈ (gtt_lang G)+" by (meson trancl.trancl_into_trancl trancl_trans)
  qed (auto intro!: trancl_gtt_lang_arg_closed)
  then show ?thesis by (auto simp: gtt_accept_def)
qed

lemma GTT_trancl_alang:
  "agtt_lang (GTT_trancl G) = gtrancl_rel UNIV (agtt_lang G)"
  using GTT_trancl_asound GTT_trancl_acomplete by blast

lemma GTT_trancl_lang:
  "gtt_lang (GTT_trancl G) = (gtt_lang G)+"
  using GTT_trancl_sound GTT_trancl_complete by blast

end
body>

Theory Pair_Automaton

theory Pair_Automaton
  imports Tree_Automata_Complement GTT_Compose
begin

subsection ‹Pair automaton and anchored GTTs›

definition pair_at_lang :: "('q, 'f) gtt ⇒ ('q × 'q) fset ⇒ 'f gterm rel" where
  "pair_at_lang 𝒢 Q = {(s, t) | s t p q. q |∈| gta_der (fst 𝒢) s ∧ p |∈| gta_der (snd 𝒢) t ∧ (q, p) |∈| Q}"

lemma pair_at_lang_restr_states:
  "pair_at_lang 𝒢 Q = pair_at_lang 𝒢 (Q |∩| (𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)))"
  by (auto simp: pair_at_lang_def gta_der_def) (meson gterm_ta_der_states) 

lemma pair_at_langE:
  assumes "(s, t) ∈ pair_at_lang 𝒢 Q"
  obtains q p where "(q, p) |∈| Q" and "q |∈| gta_der (fst 𝒢) s" and "p |∈| gta_der (snd 𝒢) t"
  using assms by (auto simp: pair_at_lang_def)

lemma pair_at_langI:
  assumes "q |∈| gta_der (fst 𝒢) s" "p |∈| gta_der (snd 𝒢) t" "(q, p) |∈| Q"
  shows "(s, t) ∈ pair_at_lang 𝒢 Q"
  using assms by (auto simp: pair_at_lang_def)

lemma pair_at_lang_fun_states:
  assumes "finj_on f (𝒬 (fst 𝒢))" and "finj_on g (𝒬 (snd 𝒢))"
    and "Q |⊆| 𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)"
  shows "pair_at_lang 𝒢 Q = pair_at_lang (map_prod (fmap_states_ta f) (fmap_states_ta g) 𝒢) (map_prod f g |`| Q)"
    (is "?LS = ?RS")
proof
  {fix s t assume "(s, t) ∈ ?LS"
    then have "(s, t) ∈ ?RS" using ta_der_fmap_states_ta_mono[of f "fst 𝒢" s]
      using ta_der_fmap_states_ta_mono[of g "snd 𝒢" t]
      by (force simp: gta_der_def map_prod_def image_iff  elim!: pair_at_langE split: prod.split intro!: pair_at_langI)}
  then show "?LS ⊆ ?RS" by auto
next
  {fix s t assume "(s, t) ∈ ?RS"
    then obtain p q where rs: "p |∈| ta_der (fst 𝒢) (term_of_gterm s)" "f p |∈| ta_der (fmap_states_ta f (fst 𝒢)) (term_of_gterm s)" and
      ts: "q |∈| ta_der (snd 𝒢) (term_of_gterm t)" "g q |∈| ta_der (fmap_states_ta g (snd 𝒢)) (term_of_gterm t)" and
      st: "(f p, g q) |∈| (map_prod f g |`| Q)" using assms ta_der_fmap_states_inv[of f "fst 𝒢" _ s]
      using ta_der_fmap_states_inv[of g "snd 𝒢" _ t]
      by (auto simp: gta_der_def adapt_vars_term_of_gterm elim!: pair_at_langE)
         (metis (no_types, opaque_lifting) fimageE fmap_prod_fimageI ta_der_fmap_states_conv)
    then have "p |∈| 𝒬 (fst 𝒢)" "q |∈| 𝒬 (snd 𝒢)" by auto
    then have "(p, q) |∈| Q" using assms st unfolding fimage_iff fBex_def
      by (auto dest!: fsubsetD simp: finj_on_eq_iff)
    then have "(s, t) ∈ ?LS" using st rs(1) ts(1) by (auto simp: gta_der_def intro!: pair_at_langI)}
  then show "?RS ⊆ ?LS" by auto
qed

lemma converse_pair_at_lang:
  "(pair_at_lang 𝒢 Q)¯ = pair_at_lang (prod.swap 𝒢) (Q|¯|)"
  by (auto simp: pair_at_lang_def)

lemma pair_at_agtt:
  "agtt_lang 𝒢 = pair_at_lang 𝒢 (fId_on (gtt_interface 𝒢))"
  by (auto simp: agtt_lang_def gtt_interface_def pair_at_lang_def gtt_states_def gta_der_def fId_on_iff)

definition Δ_eps_pair where
  "Δ_eps_pair 𝒢1 Q1 𝒢2 Q2 ≡  Q1 |O| Δε (snd 𝒢1) (fst 𝒢2) |O| Q2"

lemma pair_comp_sound1:
  assumes "(s, t) ∈ pair_at_lang 𝒢1 Q1"
    and "(t, u) ∈ pair_at_lang 𝒢2 Q2"
  shows "(s, u) ∈ pair_at_lang (fst 𝒢1, snd 𝒢2) (Δ_eps_pair 𝒢1 Q1 𝒢2 Q2)"
proof -
  from pair_at_langE assms obtain p q  q' r where
    wit: "(p, q) |∈| Q1" "p |∈| gta_der (fst 𝒢1) s" "q |∈| gta_der (snd 𝒢1) t"
    "(q', r) |∈| Q2" "q' |∈| gta_der (fst 𝒢2) t" "r |∈| gta_der (snd 𝒢2) u"
      by metis
  from wit(3, 5) have "(q, q') |∈| Δε (snd 𝒢1) (fst 𝒢2)"
    by (auto simp: Δε_def' gta_der_def intro!: exI[of _ "term_of_gterm t"])
  then have "(p, r) |∈| Δ_eps_pair 𝒢1 Q1 𝒢2 Q2" using wit(1, 4)
    by (auto simp: Δ_eps_pair_def)
  then show ?thesis using wit(2, 6) unfolding pair_at_lang_def
    by auto
qed

lemma pair_comp_sound2:
  assumes "(s, u) ∈  pair_at_lang (fst 𝒢1, snd 𝒢2) (Δ_eps_pair 𝒢1 Q1 𝒢2 Q2)"
  shows "∃ t. (s, t) ∈ pair_at_lang 𝒢1 Q1 ∧ (t, u) ∈ pair_at_lang 𝒢2 Q2"
  using assms unfolding pair_at_lang_def Δ_eps_pair_def
  by (auto simp: Δε_def' gta_der_def) (metis gterm_of_term_inv)

lemma pair_comp_sound:
  "pair_at_lang 𝒢1 Q1 O pair_at_lang 𝒢2 Q2 = pair_at_lang (fst 𝒢1, snd 𝒢2) (Δ_eps_pair 𝒢1 Q1 𝒢2 Q2)"
  by (auto simp: pair_comp_sound1 pair_comp_sound2 relcomp.simps)

inductive_set Δ_Atrans_set :: "('q × 'q) fset ⇒ ('q, 'f) ta ⇒ ('q, 'f) ta ⇒ ('q × 'q) set" for Q 𝒜 ℬ where
  base [simp]: "(p, q) |∈| Q ⟹ (p, q) ∈ Δ_Atrans_set Q 𝒜 ℬ"
| step [intro]: "(p, q) ∈ Δ_Atrans_set Q 𝒜 ℬ ⟹ (q, r) |∈| Δε ℬ 𝒜 ⟹
     (r, v) ∈ Δ_Atrans_set Q 𝒜 ℬ ⟹ (p, v) ∈ Δ_Atrans_set Q 𝒜 ℬ"

lemma Δ_Atrans_set_states:
  "(p, q) ∈ Δ_Atrans_set Q 𝒜 ℬ ⟹ (p, q) ∈ fset ((fst |`| Q |∪| 𝒬 𝒜) |×| (snd |`| Q |∪| 𝒬 ℬ))"
  by (induct rule: Δ_Atrans_set.induct) (auto simp: fimage_iff fBex_def simp flip: fmember.rep_eq)

lemma finite_Δ_Atrans_set: "finite (Δ_Atrans_set Q 𝒜 ℬ)"
proof -
  have "Δ_Atrans_set Q 𝒜 ℬ ⊆ fset ((fst |`| Q |∪| 𝒬 𝒜) |×| (snd |`| Q |∪| 𝒬 ℬ))"
    using Δ_Atrans_set_states by auto
  from finite_subset[OF this] show ?thesis by simp
qed

context
includes fset.lifting
begin
lift_definition Δ_Atrans ::  "('q × 'q) fset ⇒ ('q, 'f) ta ⇒ ('q, 'f) ta ⇒ ('q × 'q) fset" is Δ_Atrans_set
  by (simp add: finite_Δ_Atrans_set)

lemmas Δ_Atrans_base [simp] = Δ_Atrans_set.base [Transfer.transferred]
lemmas Δ_Atrans_step [intro] = Δ_Atrans_set.step [Transfer.transferred]
lemmas Δ_Atrans_cases = Δ_Atrans_set.cases[Transfer.transferred]
lemmas Δ_Atrans_induct [consumes 1, case_names base step] = Δ_Atrans_set.induct[Transfer.transferred]
end

abbreviation "Δ_Atrans_gtt 𝒢 Q ≡ Δ_Atrans Q (fst 𝒢) (snd 𝒢)"

lemma pair_trancl_sound1:
  assumes "(s, t) ∈ (pair_at_lang 𝒢 Q)+"
  shows "∃ q p. p |∈| gta_der (fst 𝒢) s ∧ q |∈| gta_der (snd 𝒢) t ∧ (p, q) |∈| Δ_Atrans_gtt 𝒢 Q"
  using assms
proof (induct)
  case (step t v)
  obtain p q r r' where reach_t: "r |∈| gta_der (fst 𝒢) t" "q |∈| gta_der (snd 𝒢) t" and
    reach: "p |∈| gta_der (fst 𝒢) s" "r' |∈| gta_der (snd 𝒢) v" and
    st: "(p, q) |∈| Δ_Atrans_gtt 𝒢 Q"  "(r, r') |∈| Q" using step(2, 3)
    by (auto simp: pair_at_lang_def)
  from reach_t have "(q, r) |∈| Δε (snd 𝒢) (fst 𝒢)"
    by (auto simp: Δε_def' gta_der_def intro: ground_term_of_gterm)
  then have "(p, r') |∈| Δ_Atrans_gtt 𝒢 Q" using st by auto
  then show ?case using reach reach_t
    by (auto simp: pair_at_lang_def gta_der_def Δε_def' intro: ground_term_of_gterm)
qed (auto simp: pair_at_lang_def intro: Δ_Atrans_base)

lemma pair_trancl_sound2:
  assumes "(p, q) |∈| Δ_Atrans_gtt 𝒢 Q"
    and "p |∈| gta_der (fst 𝒢) s" "q |∈| gta_der (snd 𝒢) t"
  shows "(s, t) ∈ (pair_at_lang 𝒢 Q)+" using assms
proof (induct arbitrary: s t rule:Δ_Atrans_induct)
  case (step p q r v)
  from step(2)[OF step(6)] step(5)[OF _ step(7)] step(3)
  show ?case by (auto simp: gta_der_def Δε_def' intro!: ground_term_of_gterm)
      (metis gterm_of_term_inv trancl_trans)
qed (auto simp: pair_at_lang_def)

lemma pair_trancl_sound:
  "(pair_at_lang 𝒢 Q)+ = pair_at_lang 𝒢 (Δ_Atrans_gtt 𝒢 Q)"
  by (auto simp: pair_trancl_sound2 dest: pair_trancl_sound1 elim: pair_at_langE intro: pair_at_langI)

abbreviation "fst_pair_cl 𝒜 Q ≡ TA (rules 𝒜) (eps 𝒜 |∪| (fId_on (𝒬 𝒜) |O| Q))"
definition pair_at_to_agtt :: "('q, 'f) gtt ⇒ ('q × 'q) fset ⇒ ('q, 'f) gtt" where
  "pair_at_to_agtt 𝒢 Q = (fst_pair_cl (fst 𝒢) Q , TA (rules (snd 𝒢)) (eps (snd 𝒢)))"

lemma fst_pair_cl_eps:
  assumes "(p, q) |∈| (eps (fst_pair_cl 𝒜 Q))|+|"
    and "𝒬 𝒜 |∩| snd |`| Q = {||}"
  shows "(p, q) |∈| (eps 𝒜)|+| ∨ (∃ r. (p = r ∨ (p, r) |∈| (eps 𝒜)|+|) ∧ (r, q) |∈| Q)" using assms
proof (induct rule: ftrancl_induct)
  case (Step p q r)
  then have y: "q |∈| 𝒬 𝒜" by (auto simp add: eps_trancl_statesD eps_statesD)
  have [simp]: "(p, q) |∈| Q ⟹ q |∈| snd |`| Q" for p q by (auto simp: fimage_iff) force 
  then show ?case using Step y
    by auto (simp add: ftrancl_into_trancl)
qed auto

lemma fst_pair_cl_res_aux:
  assumes "𝒬 𝒜 |∩| snd |`| Q = {||}"
    and "q |∈| ta_der (fst_pair_cl 𝒜 Q) (term_of_gterm t)"
  shows "∃ p. p |∈| ta_der 𝒜 (term_of_gterm t) ∧ (q |∉| 𝒬 𝒜 ⟶ (p, q) |∈| Q) ∧ (q |∈| 𝒬 𝒜 ⟶ p = q)" using assms
proof (induct t arbitrary: q)
  case (GFun f ts)
  then obtain qs q' where rule: "TA_rule f qs q' |∈| rules 𝒜" "length qs = length ts" and
    eps: "q' = q ∨ (q', q) |∈| (eps (fst_pair_cl 𝒜 Q))|+|" and
    reach: "∀ i < length ts. qs ! i |∈| ta_der (fst_pair_cl 𝒜 Q) (term_of_gterm (ts ! i))"
    by auto
  {fix i assume ass: "i < length ts" then have st: "qs ! i |∈| 𝒬 𝒜" using rule
      by (auto simp: rule_statesD)
    then have "qs ! i |∉| snd |`| Q" using GFun(2) by auto
    then have "qs ! i |∈| ta_der 𝒜 (term_of_gterm (ts ! i))" using reach st ass
      using fst_pair_cl_eps[OF _ GFun(2)] GFun(1)[OF nth_mem[OF ass] GFun(2), of "qs ! i"]
      by blast} note IH = this
  show ?case
  proof (cases "q' = q")
    case True
    then show ?thesis using rule reach IH
      by (auto dest: rule_statesD intro!: exI[of _ q'] exI[of _ qs])
  next
    case False note nt_eq = this
    then have eps: "(q', q) |∈| (eps (fst_pair_cl 𝒜 Q))|+|" using eps by simp
    from fst_pair_cl_eps[OF this assms(1)] show ?thesis
      using False rule IH
    proof (cases "q |∉| 𝒬 𝒜")
      case True
      from fst_pair_cl_eps[OF eps assms(1)] obtain r where
         "q' = r ∨ (q', r) |∈| (eps 𝒜)|+|" "(r, q) |∈| Q" using True
        by (auto simp: eps_trancl_statesD)
      then show ?thesis using nt_eq rule IH True
        by (auto simp: fimage_iff eps_trancl_statesD)
    next
      case False
      from fst_pair_cl_eps[OF eps assms(1)] False assms(1)
      have "(q', q) |∈| (eps 𝒜)|+|"
        by (auto simp: fimage_iff) (metis fempty_iff fimage_eqI finterI snd_conv)+
      then show ?thesis using IH rule
        by (intro exI[of _ q]) (auto simp: eps_trancl_statesD)
    qed
  qed
qed

lemma restr_distjoing:
  assumes "Q |⊆| 𝒬 𝒜 |×| 𝒬 𝔅"
    and "𝒬 𝒜 |∩| 𝒬 𝔅 = {||}"
  shows "𝒬 𝒜 |∩| snd |`| Q = {||}"
  using assms by auto

lemma pair_at_agtt_conv:
  assumes "Q |⊆| 𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)" and "𝒬 (fst 𝒢) |∩| 𝒬 (snd 𝒢) = {||}"
  shows "pair_at_lang 𝒢 Q = agtt_lang (pair_at_to_agtt 𝒢 Q)" (is "?LS = ?RS")
proof
  let ?TA = "fst_pair_cl (fst 𝒢) Q"
  {fix s t assume ls: "(s, t) ∈ ?LS"
    then obtain q p where w: "(q, p) |∈| Q" "q |∈| gta_der (fst 𝒢) s" "p |∈| gta_der (snd 𝒢) t"
      by (auto elim: pair_at_langE)
    from w(2) have "q |∈| gta_der ?TA s" "q |∈| 𝒬 (fst 𝒢)"
      using ta_der_mono'[of "fst 𝒢" ?TA "term_of_gterm s"]
      by (auto simp add: fin_mono ta_subset_def gta_der_def in_mono)
    then have "(s, t) ∈ ?RS" using w(1, 3)
      by (auto simp: pair_at_to_agtt_def agtt_lang_def gta_der_def ta_der_eps intro!: exI[of _ p])
         (metis fId_onI frelcompI funionI2 ta.sel(2) ta_der_eps)}
  then show "?LS ⊆ ?RS" by auto
next
  {fix s t assume ls: "(s, t) ∈ ?RS"
    then obtain q where w: "q |∈| ta_der (fst_pair_cl (fst 𝒢) Q) (term_of_gterm s)"
      "q |∈| ta_der (snd 𝒢) (term_of_gterm t)"
      by (auto simp: agtt_lang_def pair_at_to_agtt_def gta_der_def)
    from w(2) have "q |∈| 𝒬 (snd 𝒢)" "q |∉| 𝒬 (fst 𝒢)" using assms(2)
      by auto
    from fst_pair_cl_res_aux[OF restr_distjoing[OF assms] w(1)] this w(2)
    have "(s, t) ∈ ?LS" by (auto simp: agtt_lang_def pair_at_to_agtt_def gta_der_def intro: pair_at_langI)}
  then show "?RS ⊆ ?LS" by auto
qed

definition pair_at_to_agtt' where
  "pair_at_to_agtt' 𝒢 Q = (let 𝒜 = fmap_states_ta Inl (fst 𝒢) in
    let ℬ = fmap_states_ta Inr (snd 𝒢) in
    let Q' = Q |∩| (𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)) in
    pair_at_to_agtt (𝒜, ℬ) (map_prod Inl Inr |`| Q'))"

lemma pair_at_agtt_cost:
  "pair_at_lang 𝒢 Q = agtt_lang (pair_at_to_agtt' 𝒢 Q)"
proof -
  let ?G = "(fmap_states_ta CInl (fst 𝒢), fmap_states_ta CInr (snd 𝒢))"
  let ?Q = "(Q |∩| (𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)))"
  let ?Q' = "map_prod CInl CInr |`| ?Q"
  have *: "pair_at_lang 𝒢 Q = pair_at_lang 𝒢 ?Q"
    using pair_at_lang_restr_states by blast
  have "pair_at_lang 𝒢 ?Q = pair_at_lang (map_prod (fmap_states_ta CInl) (fmap_states_ta CInr) 𝒢) (map_prod CInl CInr |`| ?Q)"
    by (intro pair_at_lang_fun_states[where ?𝒢 = 𝒢 and ?Q = ?Q and ?f = CInl and ?g = CInr])
       (auto simp: finj_CInl_CInr)
  then have **:"pair_at_lang 𝒢 ?Q = pair_at_lang ?G ?Q'" by (simp add: map_prod_simp')
  have "pair_at_lang ?G ?Q' = agtt_lang (pair_at_to_agtt ?G ?Q')"
    by (intro pair_at_agtt_conv[where ?𝒢 = ?G]) auto
  then show ?thesis unfolding * ** pair_at_to_agtt'_def Let_def
    by simp
qed

lemma Δ_Atrans_states_stable:
  assumes "Q |⊆| 𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)"
  shows "Δ_Atrans_gtt 𝒢 Q |⊆| 𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)"
proof
  fix s assume ass: "s |∈| Δ_Atrans_gtt 𝒢 Q"
  then obtain t u where s: "s = (t, u)" by (cases s) blast
  show "s |∈| 𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)" using ass assms unfolding s
    by (induct rule: Δ_Atrans_induct) auto
qed

lemma Δ_Atrans_map_prod:
  assumes "finj_on f (𝒬 (fst 𝒢))" and "finj_on g (𝒬 (snd 𝒢))"
    and "Q |⊆| 𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)"
  shows "map_prod f g |`| (Δ_Atrans_gtt 𝒢 Q) = Δ_Atrans_gtt (map_prod (fmap_states_ta f) (fmap_states_ta g) 𝒢) (map_prod f g |`| Q)"
    (is "?LS = ?RS")
proof -
  {fix p q assume "(p, q) |∈| Δ_Atrans_gtt 𝒢 Q"
    then have "(f p, g q) |∈| ?RS" using assms
    proof (induct rule: Δ_Atrans_induct)
      case (step p q r v)
      from step(3, 6, 7) have "(g q, f r) |∈| Δε (fmap_states_ta g (snd 𝒢)) (fmap_states_ta f (fst 𝒢))"
        by (auto simp: Δε_def' intro!: ground_term_of_gterm)
           (metis ground_term_of_gterm ground_term_to_gtermD ta_der_to_fmap_states_der)
      then show ?case using step by auto
    qed (auto simp add: fmap_prod_fimageI)}
  moreover
  {fix p q assume "(p, q) |∈| ?RS"
    then have "(p, q) |∈| ?LS" using assms
    proof (induct rule: Δ_Atrans_induct)
      case (step p q r v)
      let ?f = "the_finv_into (𝒬 (fst 𝒢)) f" let ?g = "the_finv_into (𝒬 (snd 𝒢)) g"
      have sub: "Δε (snd 𝒢) (fst 𝒢) |⊆| 𝒬 (snd 𝒢) |×| 𝒬 (fst 𝒢)"
        using Δε_statesD(1, 2) by fastforce
      have s_e: "(?f p, ?g q) |∈| Δ_Atrans_gtt 𝒢 Q" "(?f r, ?g v) |∈| Δ_Atrans_gtt 𝒢 Q"
        using step assms(1, 2) fsubsetD[OF Δ_Atrans_states_stable[OF assms(3)]]
        using finj_on_eq_iff[OF assms(1)] finj_on_eq_iff
        using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)]
        by auto
      from step(3) have "(?g q, ?f r) |∈| Δε (snd 𝒢) (fst 𝒢)"
        using step(6-) sub
        using ta_der_fmap_states_conv[OF assms(1)] ta_der_fmap_states_conv[OF assms(2)]
        using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)]
        by (auto simp: Δε_fmember fimage_iff fBex_def)
           (metis ground_term_of_gterm ground_term_to_gtermD ta_der_fmap_states_inv)
      then have "(q, r) |∈| map_prod g f |`| Δε (snd 𝒢) (fst 𝒢)" using step
        using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)] sub
        by auto (smt Δε_statesD(1, 2) f_the_finv_into_f fmap_prod_fimageI fmap_states)
      then show ?case using s_e assms(1, 2) s_e
        using fsubsetD[OF sub]
        using fsubsetD[OF Δ_Atrans_states_stable[OF assms(3)]]
        using Δ_Atrans_step[of "?f p" "?g q" Q "fst 𝒢" "snd 𝒢" "?f r" "?g v"]
        using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)]
        by  (auto simp: fimage_iff fBex_def)
            (smt Pair_inject prod_fun_fimageE step.hyps(2) step.hyps(5) step.prems(3))
    qed auto}
  ultimately show ?thesis by auto
qed

― ‹Section: Pair Automaton is closed under Determinization›

definition Q_pow where
  "Q_pow Q 𝒮1 𝒮2 =
    {|(Wrapp X, Wrapp Y) | X Y p q. X |∈| fPow 𝒮1 ∧ Y |∈| fPow 𝒮2 ∧ p |∈| X ∧ q |∈| Y ∧ (p, q) |∈| Q|}"

lemma Q_pow_fmember:
  "(X, Y) |∈| Q_pow Q 𝒮1 𝒮2 ⟷ (∃ p q. ex X |∈| fPow 𝒮1 ∧ ex Y |∈| fPow 𝒮2 ∧ p |∈| ex X ∧ q |∈| ex Y ∧ (p, q) |∈| Q)"
proof -
  let ?S = "{(Wrapp X, Wrapp Y) | X Y p q. X |∈| fPow 𝒮1 ∧ Y |∈| fPow 𝒮2 ∧ p |∈| X ∧ q |∈| Y ∧ (p, q) |∈| Q}" 
  have "?S ⊆ map_prod Wrapp Wrapp ` fset (fPow 𝒮1 |×| fPow 𝒮2)" by (auto simp flip: fmember.rep_eq)
  from finite_subset[OF this] show ?thesis unfolding Q_pow_def
    apply auto apply blast
    by (meson FSet_Lex_Wrapper.exhaust_sel)
qed

lemma pair_automaton_det_lang_sound_complete:
  "pair_at_lang 𝒢 Q = pair_at_lang (map_both ps_ta 𝒢) (Q_pow Q (𝒬 (fst 𝒢)) (𝒬 (snd 𝒢)))" (is "?LS = ?RS")
proof -
  {fix s t assume "(s, t) ∈ ?LS"
    then obtain  p q where
      res : "p |∈| ta_der (fst 𝒢) (term_of_gterm s)"
      "q |∈| ta_der (snd 𝒢) (term_of_gterm t)" "(p, q) |∈| Q"
      by (auto simp: pair_at_lang_def gta_der_def)
    from ps_rules_complete[OF this(1)] ps_rules_complete[OF this(2)] this(3)
    have "(s, t) ∈ ?RS" using fPow_iff ps_ta_states'
      by (auto simp: pair_at_lang_def gta_der_def Q_pow_fmember)
         force}
  moreover
  {fix s t assume "(s, t) ∈ ?RS" then have "(s, t) ∈ ?LS"
      using ps_rules_sound
      by (auto simp: pair_at_lang_def gta_der_def ps_ta_def Let_def Q_pow_fmember) blast}
  ultimately show ?thesis by auto
qed

lemma pair_automaton_complement_sound_complete:
  assumes "partially_completely_defined_on 𝒜 ℱ" and "partially_completely_defined_on ℬ ℱ"
    and "ta_det 𝒜" and "ta_det ℬ"
  shows "pair_at_lang (𝒜, ℬ) (𝒬 𝒜 |×| 𝒬 ℬ |-| Q) = gterms (fset ℱ) × gterms (fset ℱ) - pair_at_lang (𝒜, ℬ) Q"
  using assms unfolding partially_completely_defined_on_def pair_at_lang_def
  apply (auto simp: gta_der_def)
  apply (metis ta_detE)
  apply fastforce
  done

end
class="head">

Theory AGTT

theory AGTT
  imports GTT GTT_Transitive_Closure Pair_Automaton
begin


definition AGTT_union where
  "AGTT_union 𝒢1 𝒢2 ≡ (ta_union (fst 𝒢1) (fst 𝒢2),
                       ta_union (snd 𝒢1) (snd 𝒢2))"

abbreviation AGTT_union' where
  "AGTT_union' 𝒢1 𝒢2 ≡ AGTT_union (fmap_states_gtt Inl 𝒢1) (fmap_states_gtt Inr 𝒢2)"

lemma disj_gtt_states_disj_fst_ta_states:
  assumes dist_st: "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "𝒬 (fst 𝒢1) |∩| 𝒬 (fst 𝒢2) = {||}"
  using assms unfolding gtt_states_def by auto

lemma disj_gtt_states_disj_snd_ta_states:
  assumes dist_st: "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "𝒬 (snd 𝒢1) |∩| 𝒬 (snd 𝒢2) = {||}"
  using assms unfolding gtt_states_def by auto

lemma ta_der_not_contains_undefined_state:
  assumes "q |∉| 𝒬 T" and "ground t"
  shows "q |∉| ta_der T t"
  using ground_ta_der_states[OF assms(2)] assms(1)
  by blast

lemma AGTT_union_sound1:
  assumes dist_st: "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "agtt_lang (AGTT_union 𝒢1 𝒢2) ⊆ agtt_lang 𝒢1 ∪ agtt_lang 𝒢2"
proof -
  let ?TA_A = "ta_union (fst 𝒢1) (fst 𝒢2)"
  let ?TA_B = "ta_union (snd 𝒢1) (snd 𝒢2)"
  {fix s t assume ass: "(s, t) ∈ agtt_lang (AGTT_union 𝒢1 𝒢2)"
    then obtain q where ls: "q |∈| ta_der ?TA_A (term_of_gterm s)" and
      rs: "q |∈| ta_der ?TA_B (term_of_gterm t)"
      by (auto simp add: AGTT_union_def agtt_lang_def gta_der_def)
    then have "(s, t) ∈ agtt_lang 𝒢1 ∨ (s, t) ∈ agtt_lang 𝒢2"
    proof (cases "q |∈| gtt_states 𝒢1")
      case True
      then have "q |∉| gtt_states 𝒢2" using dist_st
        by blast
      then have nt_fst_st: "q |∉| 𝒬 (fst 𝒢2)" and
        nt_snd_state: "q |∉| 𝒬 (snd 𝒢2)" by (auto simp add: gtt_states_def)
      from True show ?thesis
        using ls rs
        using ta_der_not_contains_undefined_state[OF nt_fst_st]
        using ta_der_not_contains_undefined_state[OF nt_snd_state]
        unfolding gtt_states_def agtt_lang_def gta_der_def
        using ta_union_der_disj_states[OF disj_gtt_states_disj_fst_ta_states[OF dist_st]]
        using ta_union_der_disj_states[OF disj_gtt_states_disj_snd_ta_states[OF dist_st]]
        using ground_term_of_gterm by blast
    next
      case False
      then have "q |∉| gtt_states 𝒢1" by (metis IntI dist_st emptyE)
      then have nt_fst_st: "q |∉| 𝒬 (fst 𝒢1)" and
        nt_snd_state: "q |∉| 𝒬 (snd 𝒢1)" by (auto simp add: gtt_states_def)
      from False show ?thesis
        using ls rs
        using ta_der_not_contains_undefined_state[OF nt_fst_st]
        using ta_der_not_contains_undefined_state[OF nt_snd_state]
        unfolding gtt_states_def agtt_lang_def gta_der_def
        using ta_union_der_disj_states[OF disj_gtt_states_disj_fst_ta_states[OF dist_st]]
        using ta_union_der_disj_states[OF disj_gtt_states_disj_snd_ta_states[OF dist_st]]
        using ground_term_of_gterm by blast
    qed}
  then show ?thesis by auto
qed

lemma AGTT_union_sound2:
  shows "agtt_lang 𝒢1 ⊆ agtt_lang (AGTT_union 𝒢1 𝒢2)"
    "agtt_lang 𝒢2 ⊆ agtt_lang (AGTT_union 𝒢1 𝒢2)"
  unfolding agtt_lang_def gta_der_def AGTT_union_def
  by auto (meson fin_mono ta_der_mono' ta_union_ta_subset)+

lemma AGTT_union_sound:
  assumes dist_st: "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "agtt_lang (AGTT_union 𝒢1 𝒢2) = agtt_lang 𝒢1 ∪ agtt_lang 𝒢2"
  using AGTT_union_sound1[OF assms] AGTT_union_sound2 by blast

lemma AGTT_union'_sound:
  fixes 𝒢1 :: "('q, 'f) gtt" and 𝒢2 :: "('q, 'f) gtt"
  shows "agtt_lang (AGTT_union' 𝒢1 𝒢2) = agtt_lang 𝒢1 ∪ agtt_lang 𝒢2"
proof -
  have map: "agtt_lang (AGTT_union' 𝒢1 𝒢2) =
    agtt_lang (fmap_states_gtt CInl 𝒢1) ∪ agtt_lang (fmap_states_gtt CInr 𝒢2)"
    by (intro  AGTT_union_sound) (auto simp add: agtt_lang_fmap_states_gtt)
  then show ?thesis by (simp add: agtt_lang_fmap_states_gtt finj_CInl_CInr)
qed

subsection ‹Anchord gtt compositon›

definition AGTT_comp :: "('q, 'f) gtt ⇒ ('q, 'f) gtt ⇒ ('q, 'f) gtt" where
  "AGTT_comp 𝒢1 𝒢2 = (let (𝒜, ℬ) = (fst 𝒢1, snd 𝒢2) in
    (TA (rules 𝒜) (eps 𝒜 |∪| (Δε (snd 𝒢1) (fst 𝒢2) |∩| (gtt_interface 𝒢1 |×| gtt_interface 𝒢2))),
     TA (rules ℬ) (eps ℬ)))"

abbreviation AGTT_comp' where
  "AGTT_comp' 𝒢1 𝒢2 ≡ AGTT_comp (fmap_states_gtt Inl 𝒢1) (fmap_states_gtt Inr 𝒢2)"

lemma AGTT_comp_sound:
  assumes "gtt_states 𝒢1 |∩| gtt_states 𝒢2 = {||}"
  shows "agtt_lang (AGTT_comp 𝒢1 𝒢2) = agtt_lang 𝒢1 O agtt_lang 𝒢2"
proof -
  let ?Q1 = "fId_on (gtt_interface 𝒢1)" let ?Q2 = "fId_on (gtt_interface 𝒢2)" 
  have lan: "agtt_lang 𝒢1 = pair_at_lang 𝒢1 ?Q1" "agtt_lang 𝒢2 = pair_at_lang 𝒢2 ?Q2"
    using pair_at_agtt[of 𝒢1] pair_at_agtt[of 𝒢2]
    by auto
  have "agtt_lang 𝒢1 O agtt_lang 𝒢2 = pair_at_lang (fst 𝒢1, snd 𝒢2) (Δ_eps_pair 𝒢1 ?Q1 𝒢2 ?Q2)"
    using pair_comp_sound1 pair_comp_sound2
    by (auto simp add: lan pair_comp_sound1 pair_comp_sound2 relcomp.simps)
  moreover have "AGTT_comp 𝒢1 𝒢2 = pair_at_to_agtt (fst 𝒢1, snd 𝒢2) (Δ_eps_pair 𝒢1 ?Q1 𝒢2 ?Q2)"
    by (auto simp: AGTT_comp_def pair_at_to_agtt_def gtt_interface_def Δε_def' Δ_eps_pair_def)
  ultimately show ?thesis using pair_at_agtt_conv[of "Δ_eps_pair 𝒢1 ?Q1 𝒢2 ?Q2" "(fst 𝒢1, snd 𝒢2)"]
    using assms
    by (auto simp: Δ_eps_pair_def gtt_states_def gtt_interface_def)
qed

lemma AGTT_comp'_sound:
  "agtt_lang (AGTT_comp' 𝒢1 𝒢2) = agtt_lang 𝒢1 O agtt_lang 𝒢2"
  using AGTT_comp_sound[of "fmap_states_gtt (Inl :: 'b ⇒ 'b + 'c) 𝒢1"
    "fmap_states_gtt (Inr :: 'c ⇒ 'b + 'c) 𝒢2"]
  by (auto simp add: agtt_lang_fmap_states_gtt disjoint_iff_not_equal agtt_lang_Inl_Inr_states_agtt)

subsection ‹Anchord gtt transitivity›

definition AGTT_trancl :: "('q, 'f) gtt ⇒ ('q + 'q, 'f) gtt" where
  "AGTT_trancl 𝒢 = (let 𝒜 = fmap_states_ta Inl (fst 𝒢) in
    (TA (rules 𝒜) (eps 𝒜 |∪| map_prod CInl CInr |`| (Δ_Atrans_gtt 𝒢 (fId_on (gtt_interface 𝒢)))),
     TA (map_ta_rule CInr id |`| (rules (snd 𝒢))) (map_both CInr |`| (eps (snd 𝒢)))))"

lemma AGTT_trancl_sound:
  shows "agtt_lang (AGTT_trancl 𝒢) = (agtt_lang 𝒢)+"
proof -
  let ?P = "map_prod (fmap_states_ta CInl) (fmap_states_ta CInr) 𝒢"
  let ?Q = "fId_on (gtt_interface 𝒢)" let ?Q' = "map_prod CInl CInr |`| ?Q"
  have inv: "finj_on CInl (𝒬 (fst 𝒢))" "finj_on CInr (𝒬 (snd 𝒢))"
    "?Q |⊆| 𝒬 (fst 𝒢) |×| 𝒬 (snd 𝒢)"
    by (auto simp: gtt_interface_def finj_CInl_CInr)
  have *: "fst |`| map_prod CInl CInr |`| Δ_Atrans_gtt 𝒢 (fId_on (gtt_interface 𝒢)) |⊆| CInl |`| 𝒬 (fst 𝒢)"
    using fsubsetD[OF Δ_Atrans_states_stable[OF inv(3)]]
    by (auto simp add: gtt_interface_def)
  from pair_at_lang_fun_states[OF inv]
  have "agtt_lang 𝒢 = pair_at_lang ?P ?Q'" using pair_at_agtt[of 𝒢] by auto
  moreover then have "(agtt_lang 𝒢)+ = pair_at_lang ?P (Δ_Atrans_gtt ?P ?Q')"
    by (simp add: pair_trancl_sound)
  moreover have "AGTT_trancl 𝒢 = pair_at_to_agtt ?P (Δ_Atrans_gtt ?P ?Q')"
    using Δ_Atrans_states_stable[OF inv(3)] Δ_Atrans_map_prod[OF inv, symmetric]
    using fId_on_frelcomp_id[OF *]
    by (auto simp: AGTT_trancl_def pair_at_to_agtt_def gtt_interface_def Let_def fmap_states_ta_def)
       (metis fmap_prod_fimageI fmap_states fmap_states_ta_def)
  moreover have "gtt_interface (map_prod (fmap_states_ta CInl) (fmap_states_ta CInr) 𝒢) = {||}"
    by (auto simp: gtt_interface_def)
  ultimately show ?thesis using pair_at_agtt_conv[of "Δ_Atrans_gtt ?P ?Q'" ?P] Δ_Atrans_states_stable[OF inv(3)]
    unfolding Δ_Atrans_map_prod[OF inv, symmetric]
    by (simp add: fimage_mono gtt_interface_def map_prod_ftimes)
qed

subsection ‹Anchord gtt triming›

abbreviation "trim_agtt ≡ trim_gtt"

lemma agtt_only_prod_lang:
  "agtt_lang (gtt_only_prod 𝒢) = agtt_lang 𝒢" (is "?Ls = ?Rs")
proof -
  let ?A = "fst 𝒢" let ?B = "snd 𝒢"
  have "?Ls ⊆ ?Rs" unfolding agtt_lang_def gtt_only_prod_def
    by (auto simp: Let_def gta_der_def dest: ta_der_ta_only_prod_ta_der)
  moreover
  {fix s t assume "(s, t) ∈ ?Rs"
    then obtain q where r: "q |∈| ta_der (fst 𝒢) (term_of_gterm s)" "q |∈| ta_der (snd 𝒢) (term_of_gterm t)"
      by (auto simp: agtt_lang_def gta_der_def)
    then have " q |∈| gtt_interface 𝒢" by (auto simp: gtt_interface_def)
    then have "(s, t) ∈ ?Ls" using r
      by (auto simp: agtt_lang_def gta_der_def gtt_only_prod_def Let_def intro!: exI[of _ q] ta_der_only_prod ta_productive_setI)}
  ultimately show ?thesis by auto
qed

lemma agtt_only_reach_lang:
  "agtt_lang (gtt_only_reach 𝒢) = agtt_lang 𝒢"
  unfolding agtt_lang_def gtt_only_reach_def
  by (auto simp: gta_der_def simp flip: ta_der_gterm_only_reach)

lemma trim_agtt_lang [simp]:
  "agtt_lang (trim_agtt G) = agtt_lang G"
  unfolding trim_gtt_def comp_def agtt_only_prod_lang agtt_only_reach_lang ..


end
dy>

Theory RRn_Automata

theory RRn_Automata
  imports Tree_Automata_Complement Ground_Ctxt
begin
section ‹Regular relations›

subsection ‹Encoding pairs of terms›

text ‹The encoding of two terms $s$ and $t$ is given by its tree domain, which is the union of the
domains of $s$ and $t$, and the labels, which arise from looking up each position in $s$ and $t$,
respectively.›

definition gpair :: "'f gterm ⇒ 'g gterm ⇒ ('f option × 'g option) gterm" where
  "gpair s t = glabel (λp. (gfun_at s p, gfun_at t p)) (gunion (gdomain s) (gdomain t))"

text ‹We provide an efficient implementation of gpair.›

definition zip_fill :: "'a list ⇒ 'b list ⇒ ('a option × 'b option) list" where
  "zip_fill xs ys = zip (map Some xs @ replicate (length ys - length xs) None)
    (map Some ys @ replicate (length xs - length ys) None)"

lemma zip_fill_code [code]:
  "zip_fill xs [] = map (λx. (Some x, None)) xs"
  "zip_fill [] ys = map (λy. (None, Some y)) ys"
  "zip_fill (x # xs) (y # ys) = (Some x, Some y) # zip_fill xs ys"
  subgoal by (induct xs) (auto simp: zip_fill_def)
  subgoal by (induct ys) (auto simp: zip_fill_def)
  subgoal by (auto simp: zip_fill_def)
  done

lemma length_zip_fill [simp]:
  "length (zip_fill xs ys) = max (length xs) (length ys)"
  by (auto simp: zip_fill_def)

lemma nth_zip_fill:
  assumes "i < max (length xs) (length ys)"
  shows "zip_fill xs ys ! i = (if i < length xs then Some (xs ! i) else None, if i < length ys then Some (ys ! i) else None)"
  using assms by (auto simp: zip_fill_def nth_append)

fun gpair_impl :: "'f gterm option ⇒ 'g gterm option ⇒ ('f option × 'g option) gterm" where
  "gpair_impl (Some s) (Some t) = gpair s t"
| "gpair_impl (Some s) None     = map_gterm (λf. (Some f, None)) s"
| "gpair_impl None     (Some t) = map_gterm (λf. (None, Some f)) t"
| "gpair_impl None     None     = GFun (None, None) []"

declare gpair_impl.simps(2-4)[code]

lemma gpair_impl_code [simp, code]:
  "gpair_impl (Some s) (Some t) =
    (case s of GFun f ss ⇒ case t of GFun g ts ⇒
    GFun (Some f, Some g) (map (λ(s, t). gpair_impl s t) (zip_fill ss ts)))"
proof (induct "gdomain s" "gdomain t" arbitrary: s t rule: gunion.induct)
  case (1 f ss g ts)
  obtain f' ss' where [simp]: "s = GFun f' ss'" by (cases s)
  obtain g' ts' where [simp]: "t = GFun g' ts'" by (cases t)
  show ?case using 1(2,3) 1(1)[of i "ss' ! i" "ts' ! i" for i]
    by (auto simp: gpair_def comp_def nth_zip_fill intro: glabel_map_gterm_conv[unfolded comp_def]
      intro!: nth_equalityI)
qed

lemma gpair_code [code]:
  "gpair s t = gpair_impl (Some s) (Some t)"
  by simp

(* export_code gpair in Haskell *)

declare gpair_impl.simps(1)[simp del]

text ‹We can easily prove some basic properties. I believe that proving them by induction with a
definition along the lines of @{const gpair_impl} would be very cumbersome.›

lemma gpair_swap:
  "map_gterm prod.swap (gpair s t) = gpair t s"
  by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gpair_def)

lemma gpair_assoc:
  defines "f ≡ λ(f, gh). (f, gh ⤜ fst, gh ⤜ snd)"
  defines "g ≡ λ(fg, h). (fg ⤜ fst, fg ⤜ snd, h)"
  shows "map_gterm f (gpair s (gpair t u)) = map_gterm g (gpair (gpair s t) u)"
  by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gpair_def f_def g_def)


subsection ‹Decoding of pairs›

fun gcollapse :: "'f option gterm ⇒ 'f gterm option" where
  "gcollapse (GFun None _) = None"
| "gcollapse (GFun (Some f) ts) = Some (GFun f (map the (filter (λt. ¬ Option.is_none t) (map gcollapse ts))))"

lemma gcollapse_groot_None [simp]:
  "groot_sym t = None ⟹ gcollapse t = None"
  "fst (groot t) = None ⟹ gcollapse t = None"
  by (cases t, simp)+

definition gfst :: "('f option × 'g option) gterm ⇒ 'f gterm" where
  "gfst = the ∘ gcollapse ∘ map_gterm fst"

definition gsnd :: "('f option × 'g option) gterm ⇒ 'g gterm" where
  "gsnd = the ∘ gcollapse ∘ map_gterm snd"

lemma filter_less_upt:
  "[i←[i..<m] . i < n] = [i..<min n m]"
proof (cases "i ≤ m")
  case True then show ?thesis
  proof (induct rule: inc_induct)
    case (step n) then show ?case by (auto simp: upt_rec[of n])
  qed simp
qed simp

lemma gcollapse_aux:
  assumes "gposs s = {p. p ∈ gposs t ∧ gfun_at t p ≠ Some None}"
  shows "gposs (the (gcollapse t)) = gposs s"
    "⋀p. p ∈ gposs s ⟹ gfun_at (the (gcollapse t)) p = (gfun_at t p ⤜ id)"
proof (goal_cases)
  define s' t' where "s' ≡ gdomain s" and "t' ≡ gdomain t"
  have *: "gposs (the (gcollapse t)) = gposs s ∧
    (∀p. p ∈ gposs s ⟶ gfun_at (the (gcollapse t)) p = (gfun_at t p ⤜ id))"
  using assms s'_def t'_def
  proof (induct s' t' arbitrary: s t rule: gunion.induct)
    case (1 f' ss' g' ts')
    obtain f ss where s [simp]: "s = GFun f ss" by (cases s)
    obtain g ts where t [simp]: "t = GFun (Some g) ts"
      using arg_cong[OF 1(2), of "λP. [] ∈ P"] by (cases t) auto
    have *: "i < length ts ⟹ ¬ Option.is_none (gcollapse (ts ! i)) ⟷ i < length ss" for i
      using arg_cong[OF 1(2), of "λP. [i] ∈ P"] by (cases "ts ! i") auto
    have l: "length ss ≤ length ts"
      using arg_cong[OF 1(2), of "λP. [length ss-1] ∈ P"] by auto
    have [simp]: "[t←map gcollapse ts . ¬ Option.is_none t] = take (length ss) (map gcollapse ts)"
      by (subst (2) map_nth[symmetric]) (auto simp add: * filter_map comp_def filter_less_upt
        cong: filter_cong[OF refl, of "[0..<length ts]", unfolded set_upt atLeastLessThan_iff]
        intro!: nth_equalityI)
    have [simp]: "i < length ss ⟹ gposs (ss ! i) = gposs (the (gcollapse (ts ! i)))" for i
      using conjunct1[OF 1(1), of i "ss ! i" "ts ! i"] l arg_cong[OF 1(2), of "λP. {p. i # p ∈ P}"]
        1(3,4) by simp
    show ?case
    proof (intro conjI allI, goal_cases A B)
      case A show ?case using l by (auto simp: comp_def split: if_splits)
    next
      case (B p) show ?case
      proof (cases p)
        case (Cons i q) then show ?thesis using arg_cong[OF 1(2), of "λP. {p. i # p ∈ P}"]
          spec[OF conjunct2[OF 1(1)], of i "ss ! i" "ts ! i" q] 1(3,4) by auto
      qed auto
    qed
  qed
  { case 1 then show ?case using * by blast
  next
    case 2 then show ?case using * by blast }
qed

lemma gfst_gpair:
  "gfst (gpair s t) = s"
proof -
  have *: "gposs s = {p ∈ gposs (map_gterm fst (gpair s t)). gfun_at (map_gterm fst (gpair s t)) p ≠ Some None}"
    using gfun_at_nongposs
    by (fastforce simp: gpair_def elim: gfun_at_possE)
  show ?thesis unfolding gfst_def comp_def using gcollapse_aux[OF *]
    by (auto intro!: eq_gterm_by_gposs_gfun_at simp: gpair_def)
qed

lemma gsnd_gpair:
  "gsnd (gpair s t) = t"
  using gfst_gpair[of t s] gpair_swap[of t s, symmetric]
  by (simp add: gfst_def gsnd_def gpair_def gterm.map_comp comp_def)

lemma gpair_impl_None_Inv:
  "map_gterm (the ∘ snd) (gpair_impl None (Some t)) = t"
  by (simp add: gterm.map_ident gterm.map_comp comp_def)

subsection ‹Contexts to gpair›

lemma gpair_context1:
  assumes "length ts = length us"
  shows "gpair (GFun f ts) (GFun f us) = GFun (Some f, Some f) (map (case_prod gpair) (zip ts us))"
  using assms unfolding gpair_code by (auto intro!: nth_equalityI simp: zip_fill_def)

lemma gpair_context2:
  assumes "⋀ i. i < length ts ⟹ ts ! i = gpair (ss ! i) (us ! i)"
  and "length ss = length ts" and "length us = length ts"
  shows "GFun (Some f, Some h) ts = gpair (GFun f ss) (GFun h us)"
  using assms unfolding gpair_code gpair_impl_code
  by (auto simp: zip_fill_def intro!: nth_equalityI)

lemma map_funs_term_some_gpair:
  shows "gpair t t = map_gterm (λf. (Some f, Some f)) t"
proof (induct t)
  case (GFun f ts)
  then show ?case by (auto intro!: gpair_context2[symmetric])
qed


lemma gpair_inject [simp]:
  "gpair s t = gpair s' t' ⟷ s = s' ∧ t = t'"
  by (metis gfst_gpair gsnd_gpair)

abbreviation gterm_to_None_Some :: "'f gterm ⇒ ('f option × 'f option) gterm" where
  "gterm_to_None_Some t ≡ map_gterm (λf. (None, Some f)) t"
abbreviation "gterm_to_Some_None t ≡ map_gterm (λf. (Some f, None)) t"

lemma inj_gterm_to_None_Some: "inj gterm_to_None_Some"
    by (meson Pair_inject gterm.inj_map inj_onI option.inject)

lemma zip_fill1:
  assumes "length ss < length ts"
  shows "zip_fill ss ts = zip (map Some ss) (map Some (take (length ss) ts)) @
    map (λ x. (None, Some x)) (drop (length ss) ts)"
  using assms by (auto simp: zip_fill_def list_eq_iff_nth_eq nth_append simp add: min.absorb2)

lemma zip_fill2:
  assumes "length ts < length ss"
  shows "zip_fill ss ts = zip (map Some (take (length ts) ss)) (map Some ts) @
    map (λ x. (Some x, None)) (drop (length ts) ss)"
  using assms by (auto simp: zip_fill_def list_eq_iff_nth_eq nth_append simp add: min.absorb2)

(* GPair position lemmas *)

(* MOVE me*)
lemma not_gposs_append [simp]:
  assumes "p ∉ gposs t"
  shows "p @ q ∈ gposs t = False" using assms poss_gposs_conv
  using poss_append_poss by blast

(*end Move *)

lemma gfun_at_gpair:
  "gfun_at (gpair s t) p = (if p ∈ gposs s then (if p ∈ gposs t
                                                 then Some (gfun_at s p, gfun_at t p)
                                                 else Some (gfun_at s p, None)) else
                           (if p ∈ gposs t then Some (None, gfun_at t p) else None))"
  using gfun_at_glabel by (auto simp: gpair_def)

lemma gposs_of_gpair [simp]:
  shows "gposs (gpair s t) = gposs s ∪ gposs t"
  by (auto simp: gpair_def)

lemma poss_to_gpair_poss:
  "p ∈ gposs s ⟹ p ∈ gposs (gpair s t)"
  "p ∈ gposs t ⟹ p ∈ gposs (gpair s t)"
  by auto

lemma gsubt_at_gpair_poss:
  assumes "p ∈ gposs s" and "p ∈ gposs t"
  shows "gsubt_at (gpair s t) p = gpair (gsubt_at s p) (gsubt_at t p)" using assms
  by (auto simp: gunion_gsubt_at_poss gfun_at_gpair intro!: eq_gterm_by_gposs_gfun_at)

lemma subst_at_gpair_nt_poss_Some_None:
  assumes "p ∈ gposs s" and "p ∉ gposs t"
  shows "gsubt_at (gpair s t) p = gterm_to_Some_None (gsubt_at s p)" using assms gfun_at_poss
  by (force simp: gunion_gsubt_at_poss gfun_at_gpair intro!: eq_gterm_by_gposs_gfun_at)

lemma subst_at_gpair_nt_poss_None_Some:
  assumes "p ∈ gposs t" and "p ∉ gposs s"
  shows "gsubt_at (gpair s t) p = gterm_to_None_Some (gsubt_at t p)" using assms gfun_at_poss
  by (force simp: gunion_gsubt_at_poss gfun_at_gpair intro!: eq_gterm_by_gposs_gfun_at)


lemma gpair_ctxt_decomposition:
  fixes C defines "p ≡ ghole_pos C"
  assumes "p ∉ gposs s" and "gpair s t = C⟨gterm_to_None_Some u⟩G"
  shows "gpair s (gctxt_at_pos t p)⟨v⟩G = C⟨gterm_to_None_Some v⟩G"
  using assms(2-)
proof -
  note p[simp] = assms(1)
  have pt: "p ∈ gposs t" and pc: "p ∈ gposs C⟨gterm_to_None_Some v⟩G"
    and pu: "p ∈ gposs C⟨gterm_to_None_Some u⟩G"
    using arg_cong[OF assms(3), of gposs] assms(2) ghole_pos_in_apply
    by auto
  have *: "gctxt_at_pos (gpair s (gctxt_at_pos t (ghole_pos C))⟨v⟩G) (ghole_pos C) = gctxt_at_pos (gpair s t) (ghole_pos C)"
    using assms(2) pt
    by (intro eq_gctxt_at_pos)
      (auto simp: gposs_gctxt_at_pos gunion_gsubt_at_poss gfun_at_gpair gfun_at_gctxt_at_pos_not_after)
  have "gsubt_at (gpair s (gctxt_at_pos t p)⟨v⟩G) p = gsubt_at C⟨gterm_to_None_Some v⟩G p"
    using pt assms(2) subst_at_gpair_nt_poss_None_Some[OF _ assms(2), of "(gctxt_at_pos t p)⟨v⟩G"]
    using ghole_pos_gctxt_at_pos
    by (simp add: ghole_pos_in_apply)
  then show ?thesis using assms(2) ghole_pos_gctxt_at_pos
    using gsubst_at_gctxt_at_eq_gtermD[OF assms(3) pu]
    by (intro gsubst_at_gctxt_at_eq_gtermI[OF _ pc])
       (auto simp: ghole_pos_in_apply * gposs_gctxt_at_pos[OF pt, unfolded p])
qed

lemma groot_gpair [simp]:
  "fst (groot (gpair s t)) = (Some (fst (groot s)), Some (fst (groot t)))"
  by (cases s; cases t) (auto simp add: gpair_code)

lemma ground_ctxt_adapt_ground [intro]:
  assumes "ground_ctxt C"
  shows "ground_ctxt (adapt_vars_ctxt C)"
  using assms by (induct C) auto

lemma adapt_vars_ctxt2 :
  assumes "ground_ctxt C"
  shows "adapt_vars_ctxt (adapt_vars_ctxt C) = adapt_vars_ctxt C" using assms
  by (induct C) (auto simp: adapt_vars2)

subsection ‹Encoding of lists of terms›

definition gencode :: "'f gterm list ⇒ 'f option list gterm" where
  "gencode ts = glabel (λp. map (λt. gfun_at t p) ts) (gunions (map gdomain ts))"

definition gdecode_nth :: "'f option list gterm ⇒ nat ⇒ 'f gterm" where
  "gdecode_nth t i = the (gcollapse (map_gterm (λf. f ! i) t))"

lemma gdecode_nth_gencode:
  assumes "i < length ts"
  shows "gdecode_nth (gencode ts) i = ts ! i"
proof -
  have *: "gposs (ts ! i) = {p ∈ gposs (map_gterm (λf. f ! i) (gencode ts)).
           gfun_at (map_gterm (λf. f ! i) (gencode ts)) p ≠ Some None}"
    using assms
    by (auto simp: gencode_def elim: gfun_at_possE dest: gfun_at_poss_gpossD) (force simp: fun_at_def' split: if_splits)
  show ?thesis unfolding gdecode_nth_def comp_def using assms gcollapse_aux[OF *]
    by (auto intro!: eq_gterm_by_gposs_gfun_at simp: gencode_def)
     (metis (no_types) gposs_map_gterm length_map list.set_map map_nth_eq_conv nth_mem) 
qed

definition gdecode :: "'f option list gterm ⇒ 'f gterm list" where
  "gdecode t = (case t of GFun f ts ⇒ map (λi. gdecode_nth t i) [0..<length f])"

lemma gdecode_gencode:
  "gdecode (gencode ts) = ts"
proof (cases "gencode ts")
  case (GFun f ts')
  have "length f = length ts" using arg_cong[OF GFun, of "λt. gfun_at t []"]
    by (auto simp: gencode_def)
  then show ?thesis using gdecode_nth_gencode[of _ ts]
    by (auto intro!: nth_equalityI simp: gdecode_def GFun)
qed

definition gencode_impl :: "'f gterm option list ⇒ 'f option list gterm" where
  "gencode_impl ts = glabel (λp. map (λt. t ⤜ (λt. gfun_at t p)) ts) (gunions (map (case_option (GFun () []) gdomain) ts))"

lemma gencode_code [code]:
  "gencode ts = gencode_impl (map Some ts)"
  by (auto simp: gencode_def gencode_impl_def comp_def)

lemma gencode_singleton:
  "gencode [t] = map_gterm (λf. [Some f]) t"
  using glabel_map_gterm_conv[unfolded comp_def, of "λt. [t]" t]
  by (simp add: gunions_def gencode_def)

lemma gencode_pair:
  "gencode [t, u] = map_gterm (λ(f, g). [f, g]) (gpair t u)"
  by (simp add: gunions_def gencode_def gpair_def map_gterm_glabel comp_def)


subsection ‹RRn relations›

definition RR1_spec where
  "RR1_spec A T ⟷ ℒ A = T"

definition RR2_spec where
  "RR2_spec A T ⟷ ℒ A = {gpair t u |t u. (t, u) ∈ T}"

definition RRn_spec where
  "RRn_spec n A R ⟷ ℒ A = gencode ` R ∧ (∀ts ∈ R. length ts = n)"

lemma RR1_to_RRn_spec:
  assumes "RR1_spec A T"
  shows "RRn_spec 1 (fmap_funs_reg (λf. [Some f]) A) ((λt. [t]) ` T)"
proof -
  have [simp]: "inj_on (λf. [Some f]) X" for X by (auto simp: inj_on_def)
  show ?thesis using assms
    by (auto simp: RR1_spec_def RRn_spec_def fmap_funs_ℒ image_comp comp_def gencode_singleton)
qed

lemma RR2_to_RRn_spec:
  assumes "RR2_spec A T"
  shows "RRn_spec 2 (fmap_funs_reg (λ(f, g). [f, g]) A) ((λ(t, u). [t, u]) ` T)"
proof -
  have [simp]: "inj_on (λ(f, g). [f, g]) X" for X by (auto simp: inj_on_def)
  show ?thesis using assms
    by (auto simp: RR2_spec_def RRn_spec_def fmap_funs_ℒ image_comp comp_def prod.case_distrib gencode_pair)
qed

lemma RRn_to_RR2_spec:
  assumes "RRn_spec 2 A T"
  shows "RR2_spec (fmap_funs_reg (λ f. (f ! 0 ,  f ! 1)) A) ((λ f. (f ! 0, f ! 1)) ` T)" (is "RR2_spec ?A ?T")
proof -
  {fix xs assume "xs ∈ T" then have "length xs = 2" using assms by (auto simp: RRn_spec_def)
    then obtain t u where *: "xs = [t, u]"
      by (metis (no_types, lifting) One_nat_def Suc_1 length_0_conv length_Suc_conv)
    have **: "(λf. (f ! 0, f ! Suc 0)) ∘ (λ(f, g). [f, g]) = id" by auto
    have "map_gterm (λf. (f ! 0, f ! Suc 0)) (gencode xs) = gpair t u"
      unfolding * gencode_pair gterm.map_comp ** gterm.map_id ..
    then have "∃ t u. xs = [t, u] ∧ map_gterm (λf. (f ! 0, f ! Suc 0)) (gencode xs) = gpair t u"
      using * by blast}
  then show ?thesis using assms
    by (force simp: RR2_spec_def RRn_spec_def fmap_funs_ℒ image_comp comp_def prod.case_distrib gencode_pair image_iff Bex_def)
qed

lemma relabel_RR1_spec [simp]:
  "RR1_spec (relabel_reg A) T ⟷ RR1_spec A T"
  by (simp add: RR1_spec_def)

lemma relabel_RR2_spec [simp]:
  "RR2_spec (relabel_reg A) T ⟷ RR2_spec A T"
  by (simp add: RR2_spec_def)

lemma relabel_RRn_spec [simp]:
  "RRn_spec n (relabel_reg A) T ⟷ RRn_spec n A T"
  by (simp add: RRn_spec_def)

lemma trim_RR1_spec [simp]:
  "RR1_spec (trim_reg A) T ⟷ RR1_spec A T"
  by (simp add: RR1_spec_def ℒ_trim)

lemma trim_RR2_spec [simp]:
  "RR2_spec (trim_reg A) T ⟷ RR2_spec A T"
  by (simp add: RR2_spec_def ℒ_trim)

lemma trim_RRn_spec [simp]:
  "RRn_spec n (trim_reg A) T ⟷ RRn_spec n A T"
  by (simp add: RRn_spec_def ℒ_trim)

lemma swap_RR2_spec:
  assumes "RR2_spec A R"
  shows "RR2_spec (fmap_funs_reg prod.swap A) (prod.swap ` R)" using assms
  by (force simp add: RR2_spec_def fmap_funs_ℒ gpair_swap image_iff)

subsection ‹Nullary automata›

lemma false_RRn_spec:
  "RRn_spec n empty_reg {}"
  by (auto simp: RRn_spec_def ℒ_epmty)

lemma true_RR0_spec:
  "RRn_spec 0 (Reg {|q|} (TA {|[] [] → q|} {||})) {[]}"
  by (auto simp: RRn_spec_def ℒ_def const_ta_lang gencode_def gunions_def)

subsection ‹Pairing RR1 languages›

text ‹cf. @{const "gpair"}.›

abbreviation "lift_Some_None s ≡ (Some s, None)"
abbreviation "lift_None_Some s ≡ (None, Some s)"
abbreviation "pair_eps A B ≡ (λ (p, q). ((Some (fst p), q), (Some (snd p), q))) |`| (eps A |×| finsert None (Some |`| 𝒬 B))"
abbreviation "pair_rule ≡ (λ (ra, rb). TA_rule (Some (r_root ra), Some (r_root rb)) (zip_fill (r_lhs_states ra) (r_lhs_states rb)) (Some (r_rhs ra), Some (r_rhs rb)))"

lemma lift_Some_None_pord_swap [simp]:
  "prod.swap ∘ lift_Some_None = lift_None_Some"
  "prod.swap ∘ lift_None_Some = lift_Some_None"
  by auto

lemma eps_to_pair_eps_Some_None:
  "(p, q) |∈| eps 𝒜 ⟹ (lift_Some_None p, lift_Some_None q) |∈| pair_eps 𝒜 ℬ"
  by force

definition pair_automaton :: "('p, 'f) ta ⇒ ('q, 'g) ta ⇒ ('p option × 'q option, 'f option × 'g option) ta" where
  "pair_automaton A B = TA 
    (map_ta_rule lift_Some_None lift_Some_None |`| rules A |∪|
     map_ta_rule lift_None_Some lift_None_Some |`| rules B |∪|
     pair_rule |`| (rules A |×| rules B))
    (pair_eps A B |∪| map_both prod.swap |`| (pair_eps B A))"

definition pair_automaton_reg where
  "pair_automaton_reg R L = Reg (Some |`| fin R |×| Some |`| fin L) (pair_automaton (ta R) (ta L))"


lemma pair_automaton_eps_simps:
  "(lift_Some_None p, p') |∈| eps (pair_automaton A B) ⟷ (lift_Some_None p, p') |∈| pair_eps A B"
  "(q , lift_Some_None q') |∈| eps (pair_automaton A B) ⟷ (q , lift_Some_None q') |∈| pair_eps A B"
  by (auto simp: pair_automaton_def eps_to_pair_eps_Some_None)

lemma pair_automaton_eps_Some_SomeD:
  "((Some p, Some p'), r) |∈| eps (pair_automaton A B) ⟹ fst r ≠ None ∧ snd r ≠ None ∧ (Some p = fst r ∨ Some p' = snd r) ∧
     (Some p ≠ fst r ⟶ (p, the (fst r)) |∈| (eps A)) ∧ (Some p' ≠ snd r ⟶ (p', the (snd r)) |∈| (eps B))"
  by (auto simp: pair_automaton_def)

lemma pair_automaton_eps_Some_SomeD2:
  "(r, (Some p, Some p')) |∈| eps (pair_automaton A B) ⟹ fst r ≠ None ∧ snd r ≠ None ∧ (fst r = Some p ∨ snd r = Some p') ∧
     (fst r ≠ Some p ⟶ (the (fst r), p) |∈| (eps A)) ∧ (snd r ≠ Some p' ⟶ (the (snd r), p') |∈| (eps B))"
  by (auto simp: pair_automaton_def)

lemma pair_eps_Some_None:
  fixes p q q'
  defines "l ≡ (p, q)" and "r ≡ lift_Some_None q'"
  assumes "(l, r) |∈| (eps (pair_automaton A B))|+|"
  shows "q = None ∧ p ≠ None ∧ (the p, q') |∈| (eps A)|+|" using assms(3, 1, 2)
proof (induct arbitrary: q' q rule: ftrancl_induct)
  case (Step b)
  then show ?case unfolding pair_automaton_eps_simps
    by (auto simp: pair_automaton_eps_simps)
       (meson not_ftrancl_into)
qed (auto simp: pair_automaton_def)

lemma pair_eps_Some_Some:
  fixes p q
  defines "l ≡ (Some p, Some q)"
  assumes "(l, r) |∈| (eps (pair_automaton A B))|+|"
  shows "fst r ≠ None ∧ snd r ≠ None ∧
      (fst l ≠ fst r ⟶ (p, the (fst r)) |∈| (eps A)|+|) ∧
      (snd l ≠ snd r ⟶ (q, the (snd r)) |∈| (eps B)|+|)"
  using assms(2, 1)
proof (induct arbitrary: p q rule: ftrancl_induct)
  case (Step b c)
  then obtain r r' where *: "b = (Some r, Some r')" by (cases b) auto
  show ?case using Step(2)
    using pair_automaton_eps_Some_SomeD[OF  Step(3)[unfolded *]]
    by (auto simp: *) (meson not_ftrancl_into)+
qed (auto simp: pair_automaton_def)

lemma pair_eps_Some_Some2:
  fixes p q
  defines "r ≡ (Some p, Some q)"
  assumes "(l, r) |∈| (eps (pair_automaton A B))|+|"
  shows "fst l ≠ None ∧ snd l ≠ None ∧
      (fst l ≠ fst r ⟶ (the (fst l), p) |∈| (eps A)|+|) ∧
      (snd l ≠ snd r ⟶ (the (snd l), q) |∈| (eps B)|+|)"
  using assms(2, 1)
proof (induct arbitrary: p q rule: ftrancl_induct)
  case (Step b c)
  from pair_automaton_eps_Some_SomeD2[OF Step(3)]
  obtain r r' where *: "c = (Some r, Some r')" by (cases c) auto
  from Step(2)[OF this] show ?case
    using pair_automaton_eps_Some_SomeD[OF  Step(3)[unfolded *]]
    by (auto simp: *) (meson not_ftrancl_into)+
qed (auto simp: pair_automaton_def)


lemma map_pair_automaton:
  "pair_automaton (fmap_funs_ta f A) (fmap_funs_ta g B) =
   fmap_funs_ta (λ(a, b). (map_option f a, map_option g b)) (pair_automaton A B)" (is "?Ls = ?Rs")
proof -
  let ?ls = "pair_rule ∘ map_prod (map_ta_rule id f) (map_ta_rule id g)"
  let ?rs = "map_ta_rule id (λ(a, b). (map_option f a, map_option g b)) ∘ pair_rule"
  have *: "(λ(a, b). (map_option f a, map_option g b)) ∘ lift_Some_None = lift_Some_None ∘ f"
    "(λ(a, b). (map_option f a, map_option g b)) ∘ lift_None_Some = lift_None_Some ∘ g"
    by (auto simp: comp_def)
  have "?ls x = ?rs x" for x
    by (cases x) (auto simp: ta_rule.map_sel)
  then have [simp]: "?ls = ?rs" by blast
  then have "rules ?Ls = rules ?Rs"
    unfolding pair_automaton_def fmap_funs_ta_def
    by (simp add: fimage_funion map_ta_rule_comp * map_prod_ftimes)
  moreover have "eps ?Ls = eps ?Rs"
    unfolding pair_automaton_def fmap_funs_ta_def
    by (simp add: fimage_funion 𝒬_def)
  ultimately show ?thesis
    by (intro TA_equalityI) simp
qed

lemmas map_pair_automaton_12 =
  map_pair_automaton[of _ _ id, unfolded fmap_funs_ta_id option.map_id]
  map_pair_automaton[of id _ _, unfolded fmap_funs_ta_id option.map_id]

lemma fmap_states_funs_ta_commute:
  "fmap_states_ta f (fmap_funs_ta g A) = fmap_funs_ta g (fmap_states_ta f A)"
proof -
  have [simp]: "map_ta_rule f id (map_ta_rule id g r) = map_ta_rule id g (map_ta_rule f id r)" for r
    by (cases r) auto
  show ?thesis
    by (auto simp: ta_rule.case_distrib fmap_states_ta_def fmap_funs_ta_def fimage_iff fBex_def split: ta_rule.splits)
qed

lemma states_pair_automaton:
  "𝒬 (pair_automaton A B) |⊆| (finsert None (Some |`| 𝒬 A) |×| (finsert None (Some |`| 𝒬 B)))"
  unfolding pair_automaton_def
  apply (intro 𝒬_subseteq_I)
  apply (auto simp: ta_rule.map_sel in_fset_conv_nth nth_zip_fill rule_statesD eps_statesD)
  apply (simp add: rule_statesD)+
  done


lemma swap_pair_automaton:
  assumes "(p, q) |∈| ta_der (pair_automaton A B) (term_of_gterm t)"
  shows "(q, p) |∈| ta_der (pair_automaton B A) (term_of_gterm (map_gterm prod.swap t))"
proof -
  let ?m = "map_ta_rule prod.swap prod.swap"
  have [simp]: "map prod.swap (zip_fill xs ys) = zip_fill ys xs" for xs ys
    by (auto simp: zip_fill_def zip_nth_conv comp_def intro!: nth_equalityI)
  let ?swp = "λX. fmap_states_ta prod.swap (fmap_funs_ta prod.swap X)"
  { fix A B
    let ?AB = "?swp (pair_automaton A B)" and ?BA = "pair_automaton B A"
    have "eps ?AB |⊆| eps ?BA" "rules ?AB |⊆| rules ?BA"
      by (auto simp: fmap_states_ta_def fmap_funs_ta_def pair_automaton_def fimage_iff ta_rule.map_comp)
         force+
  } note * = this
  let ?BA = "?swp (?swp (pair_automaton B A))" and ?AB = "?swp (pair_automaton A B)"
  have **: "r |∈| rules (pair_automaton B A) ⟹ ?m r |∈| ?m |`| rules (pair_automaton B A)" for r
    by blast
  have "r |∈| rules ?BA ⟹ r |∈| rules ?AB" "e |∈| eps ?BA ⟹ e |∈| eps ?AB" for r e
    using *[of B A] map_ta_rule_prod_swap_id
    unfolding fmap_funs_ta_def fmap_states_ta_def
      by (auto simp: map_ta_rule_comp fimage_iff fBex_def ta_rule.map_id0 intro!: exI[of _ "?m r"])
  then have "eps ?BA |⊆| eps ?AB" "rules ?BA |⊆| rules ?AB"
    by blast+
  then have "fmap_states_ta prod.swap (fmap_funs_ta prod.swap (pair_automaton A B)) = pair_automaton B A"
    using *[of A B] by (simp add: fmap_states_funs_ta_commute fmap_funs_ta_comp fmap_states_ta_comp TA_equalityI)
  then show ?thesis
    using ta_der_fmap_states_ta[OF ta_der_fmap_funs_ta[OF assms], of prod.swap prod.swap]
    by (simp add: gterm.map_comp comp_def)
qed

lemma to_ta_der_pair_automaton:
  "p |∈| ta_der A (term_of_gterm t) ⟹
    (Some p, None) |∈| ta_der (pair_automaton A B) (term_of_gterm (map_gterm (λf. (Some f, None)) t))"
  "q |∈| ta_der B (term_of_gterm u) ⟹
    (None, Some q) |∈| ta_der (pair_automaton A B) (term_of_gterm (map_gterm (λf. (None, Some f)) u))"
  "p |∈| ta_der A (term_of_gterm t) ⟹ q |∈| ta_der B (term_of_gterm u) ⟹
    (Some p, Some q) |∈| ta_der (pair_automaton A B) (term_of_gterm (gpair t u))"
proof (goal_cases sn ns ss)
  let ?AB = "pair_automaton A B"
  have 1: "(Some p, None) |∈| ta_der (pair_automaton A B) (term_of_gterm (map_gterm (λf. (Some f, None)) s))"
    if "p |∈| ta_der A (term_of_gterm s)" for A B p s
    by (intro fsubsetD[OF ta_der_mono, OF _ _ ta_der_fmap_states_ta[OF ta_der_fmap_funs_ta[OF that]],
      unfolded map_term_of_gterm id_def gterm.map_ident])
       (auto simp add: pair_automaton_def fmap_states_ta_def fmap_funs_ta_def ta_rule.map_comp image_iff eps_to_pair_eps_Some_None)
  have 2: "q |∈| ta_der B (term_of_gterm t) ⟹
    (None, Some q) |∈| ta_der ?AB (term_of_gterm (map_gterm (λg. (None, Some g)) t))"
    for q t using swap_pair_automaton[OF 1[of q B t A]] by (simp add: gterm.map_comp comp_def)
  {
    case sn then show ?case by (rule 1)
  next
    case ns then show ?case by (rule 2)
  next
    case ss then show ?case
    proof (induct t arbitrary: p q u)
      case (GFun f ts)
      obtain g us where u [simp]: "u = GFun g us" by (cases u)
      obtain p' ps where p': "f ps → p' |∈| rules A" "p' = p ∨ (p', p) |∈| (eps A)|+|" "length ps = length ts"
        "⋀i. i < length ts ⟹ ps ! i |∈| ta_der A (term_of_gterm (ts ! i))" using GFun(2) by auto
      obtain q' qs where q': "g qs → q' |∈| rules B" "q' = q ∨ (q', q) |∈| (eps B)|+|" "length qs = length us"
        "⋀i. i < length us ⟹ qs ! i |∈| ta_der B (term_of_gterm (us ! i))" using GFun(3) by auto
      have *: "Some p |∈| Some |`| 𝒬 A" "Some q' |∈| Some |`| 𝒬 B"
        using p'(2,1) q'(1)
        by (auto simp: rule_statesD eps_trancl_statesD)
      have eps: "p' = p ∧ q' = q ∨ ((Some p', Some q'), (Some p, Some q)) |∈| (eps ?AB)|+|"
      proof (cases "p' = p")
        case True note p = this then show ?thesis
        proof (cases "q' = q")
          case False
          then have "(q', q) |∈| (eps B)|+|" using q'(2) by auto 
          then show ?thesis using p'(1)
            using ftrancl_map[of "eps B" "λq. (Some p', Some q)" "eps ?AB" q' q]
            by (auto simp: p pair_automaton_def fimage_iff fBex_def rule_statesD)
        qed (simp add: p)
      next
        case False note p = this
        then have *: "(p', p) |∈| (eps A)|+|" using p'(2) by auto
        then have eps: "((Some p', Some q'), Some p, Some q') |∈| (eps (pair_automaton A B))|+|"
            using q'(1) ftrancl_map[of "eps A" "λp. (Some p, Some q')" "eps ?AB" p' p]
            by (auto simp: p pair_automaton_def fimage_iff fBex_def rule_statesD)
        show ?thesis
        proof (cases "q' = q")
          case True then show ?thesis using eps
            by simp
        next
          case False
          then have "(q', q) |∈| (eps B)|+|" using q'(2) by auto
          then have "((Some p, Some q'), Some p, Some q) |∈| (eps (pair_automaton A B))|+|"
            using * ftrancl_map[of "eps B" "λq. (Some p, Some q)" "eps ?AB" q' q]
            by (auto simp: p pair_automaton_def fimage_iff fBex_def eps_trancl_statesD)
          then show ?thesis using eps
            by (meson ftrancl_trans)
        qed
      qed
      have "(Some f, Some g) zip_fill ps qs → (Some p', Some q') |∈| rules ?AB"
        using p'(1) q'(1) by (force simp: pair_automaton_def)
      then show ?case using GFun(1)[OF nth_mem p'(4) q'(4)] p'(1 - 3)  q'(1 - 3) eps
        using 1[OF p'(4), of _ B] 2[OF q'(4)]
        by (auto simp: gpair_code nth_zip_fill less_max_iff_disj
                    intro!: exI[of _ "zip_fill ps qs"] exI[of _ "Some p'"] exI[of _ "Some q'"])
    qed
  }
qed

lemma from_ta_der_pair_automaton:
  "(None, None) |∉| ta_der (pair_automaton A B) (term_of_gterm s)"
  "(Some p, None) |∈| ta_der (pair_automaton A B) (term_of_gterm s) ⟹
    ∃t. p |∈| ta_der A (term_of_gterm t) ∧ s = map_gterm (λf. (Some f, None)) t"
  "(None, Some q) |∈| ta_der (pair_automaton A B) (term_of_gterm s) ⟹
    ∃u. q |∈| ta_der B (term_of_gterm u) ∧ s = map_gterm (λf. (None, Some f)) u"
  "(Some p, Some q) |∈| ta_der (pair_automaton A B) (term_of_gterm s) ⟹
   ∃t u. p |∈| ta_der A (term_of_gterm t) ∧ q |∈| ta_der B (term_of_gterm u) ∧ s = gpair t u"
proof (goal_cases nn sn ns ss)
  let ?AB = "pair_automaton A B"
  { fix p s A B assume "(Some p, None) |∈| ta_der (pair_automaton A B) (term_of_gterm s)"
    then have "∃t. p |∈| ta_der A (term_of_gterm t) ∧ s = map_gterm (λf. (Some f, None)) t"
    proof (induct s arbitrary: p)
      case (GFun h ss)
      obtain rs sp nq where r: "h rs → (sp, nq) |∈| rules (pair_automaton A B)"
        "sp = Some p ∧ nq = None ∨ ((sp, nq), (Some p, None)) |∈| (eps (pair_automaton A B))|+|" "length rs = length ss"
        "⋀i. i < length ss ⟹ rs ! i |∈| ta_der (pair_automaton A B) (term_of_gterm (ss ! i))"
        using GFun(2) by auto
      obtain p' where pq: "sp = Some p'" "nq = None" "p' = p ∨ (p', p) |∈| (eps A)|+|"
        using r(2) pair_eps_Some_None[of sp nq p A B]
        by (cases sp) auto
      obtain f ps where h: "h = lift_Some_None f" "rs = map lift_Some_None ps"
        "f ps → p' |∈| rules A"
        using r(1) unfolding pq(1, 2) by (auto simp: pair_automaton_def map_ta_rule_cases)
      obtain ts where "⋀i. i < length ss ⟹
        ps ! i |∈| ta_der A (term_of_gterm (ts i)) ∧ ss ! i = map_gterm (λf. (Some f, None)) (ts i)"
        using GFun(1)[OF nth_mem, of i "ps ! i" for i] r(4)[unfolded h(2)] r(3)[unfolded h(2) length_map]
        by auto metis
      then show ?case using h(3) pq(3) r(3)[unfolded h(2) length_map]
        by (intro exI[of _ "GFun f (map ts [0..<length ss])"]) (auto simp: h(1) intro!: nth_equalityI)
    qed
  } note 1 = this
  have 2: "∃u. q |∈| ta_der B (term_of_gterm u) ∧ s = map_gterm (λg. (None, Some g)) u"
    if "(None, Some q) |∈| ta_der ?AB (term_of_gterm s)" for q s
    using 1[OF swap_pair_automaton, OF that]
    by (auto simp: gterm.map_comp comp_def gterm.map_ident
      dest!: arg_cong[of "map_gterm prod.swap _" _ "map_gterm prod.swap", unfolded gterm.map_comp])
  {
    case nn
    then show ?case
      by (intro ta_der_not_reach) (auto simp: pair_automaton_def map_ta_rule_cases)
  next
    case sn then show ?case by (rule 1)
  next
    case ns then show ?case by (rule 2)
  next
    case ss then show ?case
    proof (induct s arbitrary: p q)
      case (GFun h ss)
      obtain rs sp sq where r: "h rs → (sp, sq) |∈| rules ?AB"
        "sp = Some p ∧ sq = Some q ∨ ((sp, sq), (Some p, Some q)) |∈| (eps ?AB)|+|" "length rs = length ss"
        "⋀i. i < length ss ⟹ rs ! i |∈| ta_der ?AB (term_of_gterm (ss ! i))"
        using GFun(2) by auto
      from r(2) have "sp ≠ None" "sq ≠ None" using pair_eps_Some_Some2[of "(sp, sq)" p q]
        by auto
      then obtain p' q' where pq: "sp = Some p'" "sq = Some q'"
        "p' = p ∨ (p', p) |∈| (eps A)|+|" "q' = q ∨ (q', q) |∈| (eps B)|+|"
        using r(2) pair_eps_Some_Some[where ?r = "(Some p, Some q)" and ?A = A and ?B = B]
        using pair_eps_Some_Some2[of "(sp, sq)" p q]
        by (cases sp; cases sq) auto
      obtain f g ps qs where h: "h = (Some f, Some g)" "rs = zip_fill ps qs"
        "f ps → p' |∈| rules A" "g qs → q' |∈| rules B"
        using r(1) unfolding pq(1,2) by (auto simp: pair_automaton_def map_ta_rule_cases)
      have *: "∃t u. ps ! i |∈| ta_der A (term_of_gterm t) ∧ qs ! i |∈| ta_der B (term_of_gterm u) ∧ ss ! i = gpair t u"
        if "i < length ps" "i < length qs" for i
        using GFun(1)[OF nth_mem, of i "ps ! i" "qs ! i"] r(4)[unfolded pq(1,2) h(2), of i] that
          r(3)[symmetric] by (auto simp: nth_zip_fill h(2))
      { fix i assume "i < length ss"
        then have "∃t u. (i < length ps ⟶ ps ! i |∈| ta_der A (term_of_gterm t)) ∧
            (i < length qs ⟶ qs ! i |∈| ta_der B (term_of_gterm u)) ∧
            ss ! i = gpair_impl (if i < length ps then Some t else None) (if i < length qs then Some u else None)"
          using *[of i] 1[of "ps ! i" A B "ss ! i"] 2[of "qs ! i" "ss ! i"] r(4)[of i] r(3)[symmetric]
          by (cases "i < length ps"; cases "i < length qs")
            (auto simp add: h(2) nth_zip_fill less_max_iff_disj gpair_code split: gterm.splits) }
      then obtain ts us where "⋀i. i < length ss ⟹
          (i < length ps ⟶ ps ! i |∈| ta_der A (term_of_gterm (ts i))) ∧
          (i < length qs ⟶ qs ! i |∈| ta_der B (term_of_gterm (us i))) ∧
          ss ! i = gpair_impl (if i < length ps then Some (ts i) else None) (if i < length qs then Some (us i) else None)"
        by metis
      moreover then have "⋀i. i < length ps ⟹ ps ! i |∈| ta_der A (term_of_gterm (ts i))"
         "⋀i. i < length qs ⟹ qs ! i |∈| ta_der B (term_of_gterm (us i))"
        using r(3)[unfolded h(2)] by auto
      ultimately show ?case using h(3,4) pq(3,4) r(3)[symmetric]
        by (intro exI[of _ "GFun f (map ts [0..<length ps])"] exI[of _ "GFun g (map us [0..<length qs])"])
          (auto simp: gpair_code h(1,2) less_max_iff_disj nth_zip_fill intro!: nth_equalityI split: prod.splits gterm.splits)
    qed
  }
qed


lemma diagonal_automaton:
  assumes "RR1_spec A R"
  shows "RR2_spec (fmap_funs_reg (λf. (Some f, Some f)) A) {(s, s) | s. s ∈ R}" using assms
  by (auto simp: RR2_spec_def RR1_spec_def fmap_funs_reg_def fmap_funs_gta_lang map_funs_term_some_gpair ℒ_def)

lemma pair_automaton:
  assumes "RR1_spec A T" "RR1_spec B U"
  shows "RR2_spec (pair_automaton_reg A B) (T × U)"
proof -
  let ?AB = "pair_automaton (ta A) (ta B)"
  { fix t u assume t: "t ∈ T" and u: "u ∈ U"
    obtain p where p: "p |∈| fin A" "p |∈| ta_der (ta A) (term_of_gterm t)" using t assms(1)
      by (auto simp: RR1_spec_def gta_lang_def ℒ_def gta_der_def)
    obtain q where q: "q |∈| fin B" "q |∈| ta_der (ta B) (term_of_gterm u)" using u assms(2)
      by (auto simp: RR1_spec_def gta_lang_def ℒ_def gta_der_def)
    have "gpair t u ∈ ℒ (pair_automaton_reg A B)" using p(1) q(1) to_ta_der_pair_automaton(3)[OF p(2) q(2)]
      by (auto simp: pair_automaton_reg_def ℒ_def)
  } moreover
  { fix s assume "s ∈ ℒ (pair_automaton_reg A B)"
    from this[unfolded gta_lang_def ℒ_def]
    obtain r where r: "r |∈| fin (pair_automaton_reg A B)" "r |∈| gta_der ?AB s"
      by (auto simp: pair_automaton_reg_def)
    obtain p q where pq: "r = (Some p, Some q)" "p |∈| fin A" "q |∈| fin B"
      using r(1) by (auto simp: pair_automaton_reg_def)
    from from_ta_der_pair_automaton(4)[OF r(2)[unfolded pq(1) gta_der_def]]
    obtain t u where "p |∈| ta_der (ta A) (term_of_gterm t)" "q |∈| ta_der (ta B) (term_of_gterm u)" "s = gpair t u"
      by (elim exE conjE) note * = this
    then have "t ∈ ℒ A" "u ∈ ℒ B" using pq(2,3)
      by (auto simp: ℒ_def)
    then have "∃t u. s = gpair t u ∧ t ∈ T ∧ u ∈ U" using assms
      by (auto simp: RR1_spec_def *(3) intro!: exI[of _ t, OF exI[of _ u]])
  } ultimately show ?thesis by (auto simp: RR2_spec_def)
qed

lemma pair_automaton':
  shows "ℒ (pair_automaton_reg A B) = case_prod gpair ` (ℒ A × ℒ B)"
  using pair_automaton[of A _ B] by (auto simp: RR1_spec_def RR2_spec_def)


subsection ‹Collapsing›

text ‹cf. @{const "gcollapse"}.›

fun collapse_state_list where
  "collapse_state_list Qn Qs [] = [[]]"
| "collapse_state_list Qn Qs (q # qs) = (let rec = collapse_state_list Qn Qs qs in
    (if q |∈| Qn ∧ q |∈| Qs then map (Cons None) rec @ map (Cons (Some q)) rec
     else if q |∈| Qn then map (Cons None) rec
     else if q |∈| Qs then map (Cons (Some q)) rec
     else [[]]))"

lemma collapse_state_list_inner_length:
  assumes "qss = collapse_state_list Qn Qs qs"
    and "∀ i < length qs. qs ! i |∈| Qn ∨ qs ! i |∈| Qs"
    and "i < length qss"
  shows "length (qss ! i) = length qs" using assms
proof (induct qs arbitrary: qss i)
  case (Cons q qs)
  have "∀i<length qs. qs ! i |∈| Qn ∨ qs ! i |∈| Qs" using Cons(3) by auto
  then show ?case using Cons(1)[of "collapse_state_list Qn Qs qs"] Cons(2-)
    by (auto simp: Let_def nth_append)
qed auto

lemma collapse_fset_inv_constr:
  assumes "∀ i < length qs'. qs ! i |∈| Qn ∧ qs' ! i = None ∨
    qs ! i |∈| Qs ∧ qs' ! i = Some (qs ! i)"
    and "length qs = length qs'"
  shows "qs' |∈| fset_of_list (collapse_state_list Qn Qs qs)" using assms
proof (induct qs arbitrary: qs')
  case (Cons q qs)
  have "(tl qs') |∈| fset_of_list (collapse_state_list Qn Qs qs)" using Cons(2-)
    by (intro Cons(1)[of "tl qs'"]) (cases qs', auto)
  then show ?case using Cons(2-)
    by (cases qs') (auto simp: Let_def image_def)
qed auto

lemma collapse_fset_inv_constr2:
  assumes "∀ i < length qs. qs ! i |∈| Qn ∨ qs ! i |∈| Qs"
    and "qs' |∈| fset_of_list (collapse_state_list Qn Qs qs)" and "i < length qs'"
  shows "qs ! i |∈| Qn ∧ qs' ! i = None ∨ qs ! i |∈| Qs ∧ qs' ! i = Some (qs ! i)"
  using assms
proof (induct qs arbitrary: qs' i)
  case (Cons a qs)
  have "i ≠ 0 ⟹ qs ! (i - 1) |∈| Qn ∧ tl qs' ! (i - 1) = None ∨ qs ! (i - 1) |∈| Qs ∧ tl qs' ! (i - 1) = Some (qs ! (i - 1))"
    using Cons(2-)
    by (intro Cons(1)[of "tl qs'" "i - 1"]) (auto simp: Let_def split: if_splits)
  then show ?case using Cons(2-)
    by (cases i) (auto simp: Let_def split: if_splits)
qed auto

definition collapse_rule where
  "collapse_rule A Qn Qs =
    |⋃| ((λ r. fset_of_list (map (λ qs. TA_rule (r_root r) qs (Some (r_rhs r))) (collapse_state_list Qn Qs (r_lhs_states r)))) |`|
    ffilter (λ r. (∀ i < length (r_lhs_states r). r_lhs_states r ! i |∈| Qn ∨ r_lhs_states r ! i |∈| Qs))
      (ffilter (λ r. r_root r ≠ None) (rules A)))"

definition collapse_rule_fset where
  "collapse_rule_fset A Qn Qs = (λ r. TA_rule (the (r_root r)) (map the (filter (λq. ¬ Option.is_none q) (r_lhs_states r))) (the (r_rhs r))) |`|
     collapse_rule A Qn Qs"

lemma collapse_rule_set_conv:
  "fset (collapse_rule_fset A Qn Qs) = {TA_rule f (map the (filter (λq. ¬ Option.is_none q) qs')) q | f qs qs' q.
      TA_rule (Some f) qs q |∈| rules A ∧ length qs = length qs' ∧
      (∀i < length qs. qs ! i |∈| Qn ∧ qs' ! i = None ∨ qs ! i |∈| Qs ∧ (qs' ! i) = Some (qs ! i))} " (is "?Ls = ?Rs")
proof
  {fix f qs' q qs assume ass: "TA_rule (Some f) qs q |∈| rules A"
    "length qs = length qs'"
    "∀i < length qs. qs ! i |∈| Qn ∧ qs' ! i = None ∨ qs ! i |∈| Qs ∧ (qs' ! i) = Some (qs ! i)"
    then have "TA_rule (Some f) qs' (Some q) |∈| collapse_rule A Qn Qs"
      using collapse_fset_inv_constr[of qs' qs Qn Qs] unfolding collapse_rule_def
      by (auto simp: fset_of_list.rep_eq fimage_iff intro!: fBexI[of _ "TA_rule (Some f) qs q"])
    then have "TA_rule f (map the (filter (λq. ¬ Option.is_none q) qs')) q ∈ ?Ls"
      unfolding collapse_rule_fset_def
      by (auto simp: image_iff Bex_def fmember.rep_eq intro!: exI[of _"TA_rule (Some f) qs' (Some q)"])}
  then show "?Rs ⊆ ?Ls" by blast
next
  {fix f qs q assume ass: "TA_rule f qs q ∈ ?Ls"
    then obtain ps qs' where w: "TA_rule (Some f) ps q |∈| rules A"
      "∀ i < length ps. ps ! i |∈| Qn ∨ ps ! i |∈| Qs" 
      "qs' |∈| fset_of_list (collapse_state_list Qn Qs ps)"
      "qs = map the (filter (λq. ¬ Option.is_none q) qs')"
      unfolding collapse_rule_fset_def collapse_rule_def
        by (auto simp: fmember.rep_eq ffUnion.rep_eq fset_of_list.rep_eq) (metis ta_rule.collapse)
    then have "∀ i < length qs'. ps ! i |∈| Qn ∧ qs' ! i = None ∨ ps ! i |∈| Qs ∧ qs' ! i = Some (ps ! i)"
      using collapse_fset_inv_constr2
      by metis
    moreover have "length ps = length qs'"
      using collapse_state_list_inner_length[of _ Qn Qs ps]
      using w(2, 3) calculation(1)
      by (auto simp: in_fset_conv_nth)
    ultimately have "TA_rule f qs q ∈ ?Rs"
      using w(1) unfolding w(4)
      by auto fastforce}
  then show "?Ls ⊆ ?Rs" 
    by (intro subsetI) (metis (no_types, lifting) ta_rule.collapse) 
qed


lemma collapse_rule_fmember [simp]:
  "TA_rule f qs q |∈| (collapse_rule_fset A Qn Qs) ⟷ (∃ qs' ps.
   qs = map the (filter (λq. ¬ Option.is_none q) qs') ∧ TA_rule (Some f) ps q |∈| rules A ∧ length ps = length qs' ∧
  (∀i < length ps. ps ! i |∈| Qn ∧ qs' ! i = None ∨ ps ! i |∈| Qs ∧ (qs' ! i) = Some (ps ! i)))"
  unfolding fmember.rep_eq collapse_rule_set_conv
  by auto

definition "Qn A ≡ (let S = (r_rhs |`| ffilter (λ r. r_root r = None) (rules A)) in (eps A)|+| |``| S |∪| S)"
definition "Qs A ≡ (let S = (r_rhs |`| ffilter (λ r. r_root r ≠ None) (rules A)) in (eps A)|+| |``| S |∪| S)"

lemma Qn_member_iff [simp]:
  "q |∈| Qn A ⟷ (∃ ps p. TA_rule None ps p |∈| rules A ∧ (p = q ∨ (p, q) |∈| (eps A)|+|))" (is "?Ls ⟷ ?Rs")
proof -
  {assume ass: "q |∈| Qn A" then obtain r where
      "r_rhs r = q ∨ (r_rhs r, q) |∈| (eps A)|+|" "r |∈| rules A" "r_root r = None"
      by (force simp: Qn_def Image_def image_def Let_def fImage.rep_eq simp flip: fmember.rep_eq)
    then have "?Ls ⟹ ?Rs"  by (cases r) auto}
  moreover have "?Rs ⟹ ?Ls" by (force simp: Qn_def Image_def image_def Let_def fImage.rep_eq fmember.rep_eq)
  ultimately show ?thesis by blast
qed

lemma Qs_member_iff [simp]:
  "q |∈| Qs A ⟷ (∃ f ps p. TA_rule (Some f) ps p |∈| rules A ∧ (p = q ∨ (p, q) |∈| (eps A)|+|))"  (is "?Ls ⟷ ?Rs")
proof -
  {assume ass: "q |∈| Qs A" then obtain f r where
      "r_rhs r = q ∨ (r_rhs r, q) |∈| (eps A)|+|" "r |∈| rules A" "r_root r = Some f"
      by (force simp: Qs_def Image_def image_def Let_def fImage.rep_eq simp flip: fmember.rep_eq)
    then have "?Ls ⟹ ?Rs"  by (cases r) auto}
  moreover have "?Rs ⟹ ?Ls" by (force simp: Qs_def Image_def image_def Let_def fImage.rep_eq fmember.rep_eq)
  ultimately show ?thesis by blast
qed


lemma collapse_Qn_Qs_set_conv:
  "fset (Qn A) = {q' |qs q q'. TA_rule None qs q |∈| rules A ∧ (q = q' ∨ (q, q') |∈| (eps A)|+|)}" (is "?Ls1 = ?Rs1")
  "fset (Qs A) = {q' |f qs q q'. TA_rule (Some f) qs q |∈| rules A ∧ (q = q' ∨ (q, q') |∈| (eps A)|+|)}"  (is "?Ls2 = ?Rs2")
  by (auto simp flip: fmember.rep_eq) force+

definition collapse_automaton :: "('q, 'f option) ta ⇒ ('q, 'f) ta" where
  "collapse_automaton A = TA (collapse_rule_fset A (Qn A) (Qs A)) (eps A)"

definition collapse_automaton_reg where
  "collapse_automaton_reg R = Reg (fin R) (collapse_automaton (ta R))"

lemma ta_states_collapse_automaton:
  "𝒬 (collapse_automaton A) |⊆| 𝒬 A"
  apply (intro 𝒬_subseteq_I)
  apply (auto simp: collapse_automaton_def fmember.rep_eq collapse_Qn_Qs_set_conv collapse_rule_set_conv
    fset_of_list.rep_eq in_set_conv_nth rule_statesD[unfolded fmember.rep_eq] eps_statesD[unfolded fmember.rep_eq])
  apply (metis Option.is_none_def fnth_mem notin_fset option.sel rule_statesD(3) ta_rule.sel(2))
  done

lemma last_nthI:
  assumes "i < length ts" "¬ i < length ts - Suc 0"
  shows "ts ! i = last ts" using assms
  by (induct ts arbitrary: i)
    (auto, metis last_conv_nth length_0_conv less_antisym nth_Cons')

lemma collapse_automaton':
  assumes "𝒬 A |⊆| ta_reachable A" (* cf. ta_trim *)
  shows "gta_lang Q (collapse_automaton A) = the ` (gcollapse ` gta_lang Q A - {None})"
proof -
  define Qn' where "Qn' = Qn A"
  define Qs' where "Qs' = Qs A"
  {fix t assume t: "t ∈ gta_lang Q (collapse_automaton A)"
    then obtain q where q: "q |∈| Q" "q |∈| ta_der (collapse_automaton A) (term_of_gterm t)" by auto
    have "∃ t'. q |∈| ta_der A (term_of_gterm t') ∧ gcollapse t' ≠ None ∧ t = the (gcollapse t')" using q(2)
    proof (induct rule: ta_der_gterm_induct)
      case (GFun f ts ps p q)
      from GFun(1 - 3) obtain qs rs where ps: "TA_rule (Some f) qs p |∈| rules A" "length qs = length rs"
        "⋀i. i < length qs ⟹ qs ! i |∈| Qn' ∧ rs ! i = None ∨ qs ! i |∈| Qs' ∧ rs ! i = Some (qs ! i)"
        "ps = map the (filter (λq. ¬ Option.is_none q) rs)"
        by (auto simp: collapse_automaton_def Qn'_def Qs'_def)
      obtain ts' where ts':
        "ps ! i |∈| ta_der A (term_of_gterm (ts' i))" "gcollapse (ts' i) ≠ None" "ts ! i = the (gcollapse (ts' i))"
        if "i < length ts" for i using GFun(5) by metis
      from ps(2, 3, 4) have rs: "i < length qs ⟹ rs ! i = None ∨ rs ! i = Some (qs ! i)" for i
        by auto
      {fix i assume "i < length qs" "rs ! i = None"
        then have "∃ t'. groot_sym t' = None ∧ qs ! i |∈| ta_der A (term_of_gterm t')"
          using ps(1, 2) ps(3)[of i]
          by (auto simp: ta_der_trancl_eps Qn'_def groot_sym_groot_conv elim!: ta_reachable_rule_gtermE[OF assms])
             (force dest: ta_der_trancl_eps)+}
      note None = this
      {fix i assume i: "i < length qs" "rs ! i = Some (qs ! i)"
        have "map Some ps = filter (λq. ¬ Option.is_none q) rs" using ps(4)
          by (induct rs arbitrary: ps) (auto simp add: Option.is_none_def)
        from filter_rev_nth_idx[OF _ _ this, of i]
        have *: "rs ! i = map Some ps ! filter_rev_nth (λq. ¬ Option.is_none q) rs i"
          "filter_rev_nth (λq. ¬ Option.is_none q) rs i < length ps"
          using ps(2, 4) i by auto
        then have "the (rs ! i) = ps ! filter_rev_nth (λq. ¬ Option.is_none q) rs i"
          "filter_rev_nth (λq. ¬ Option.is_none q) rs i < length ps"
          by auto} note Some = this
      let ?P = "λ t i. qs ! i |∈| ta_der A (term_of_gterm t) ∧
          (rs ! i = None ⟶ groot_sym t = None) ∧
          (rs ! i = Some (qs ! i) ⟶ t = ts' (filter_rev_nth (λq. ¬ Option.is_none q) rs i))"
      {fix i assume i: "i < length qs"
        then have "∃ t. ?P t i" using Some[OF i] None[OF i] ts' ps(2, 4) GFun(2) rs[OF i]
          by (cases "rs ! i") auto}
      then obtain ts'' where ts'': "length ts'' = length qs"
        "i < length qs ⟹ qs ! i |∈| ta_der A (term_of_gterm (ts'' ! i))"
        "i < length qs ⟹ rs ! i = None ⟹ groot_sym (ts'' ! i) = None"
        "i < length qs ⟹ rs ! i = Some (qs ! i) ⟹ ts'' ! i = ts' (filter_rev_nth (λq. ¬ Option.is_none q) rs i)"
      for i using that Ex_list_of_length_P[of "length qs" ?P] by auto
      from  ts''(1, 3, 4) Some ps(2, 4) GFun(2) rs ts'(2-)
      have "map Some ts = (filter (λq. ¬ Option.is_none q) (map gcollapse ts''))"
      proof (induct ts'' arbitrary: qs rs ps ts rule: rev_induct)
        case (snoc a us)
        from snoc(2, 7) obtain r rs' where [simp]: "rs = rs' @ [r]"
          by (metis append_butlast_last_id append_is_Nil_conv length_0_conv not_Cons_self2)
        have l: "length us = length (butlast qs)" "length (butlast qs) = length (butlast rs)"
          using snoc(2, 7) by auto
        have *: "i < length (butlast qs) ⟹ butlast rs ! i = None ⟹ groot_sym (us ! i) = None" for i
          using snoc(3)[of i] snoc(2, 7)
          by (auto simp:nth_append l(1) nth_butlast split!: if_splits)
        have **: "i < length (butlast qs) ⟹ butlast rs ! i = None ∨ butlast rs ! i = Some (butlast qs ! i)" for i
          using snoc(10)[of i] snoc(2, 7) l by (auto simp: nth_append nth_butlast)
        have "i < length (butlast qs) ⟹ butlast rs ! i = Some (butlast qs ! i) ⟹
           us ! i = ts' (filter_rev_nth (λq. ¬ Option.is_none q) (butlast rs) i)" for i
          using snoc(4)[of i] snoc(2, 7) l
          by (auto simp: nth_append nth_butlast filter_rev_nth_def take_butlast)
        note IH = snoc(1)[OF l(1) * this _ _ l(2) _ _ **]
        show ?case
        proof (cases "r = None")
          case True
          then have "map Some ts = filter (λq. ¬ Option.is_none q) (map gcollapse us)"
            using snoc(2, 5-)
            by (intro IH[of ps ts]) (auto simp: nth_append nth_butlast filter_rev_nth_butlast)
          then show ?thesis using True snoc(2, 7) snoc(3)[of "length (butlast rs)"]
            by (auto simp: nth_append l(1) last_nthI split!: if_splits)
        next
          case False
          then obtain t' ss where *: "ts = ss @ [t']" using snoc(2, 7, 8, 9)
            by (cases ts) (auto, metis append_butlast_last_id list.distinct(1))
          let ?i = "filter_rev_nth (λq. ¬ Option.is_none q) rs (length us)"
          have "map Some (butlast ts) = filter (λq. ¬ Option.is_none q) (map gcollapse us)"
            using False snoc(2, 5-) l filter_rev_nth_idx
            by (intro IH[of "butlast ps" "butlast ts"])
               (fastforce simp: nth_butlast filter_rev_nth_butlast)+
          moreover have "a = ts' ?i" "?i < length ps"
            using False snoc(2, 9) l snoc(4, 6, 10)[of "length us"]
            by (auto simp: nth_append)
          moreover have "filter_rev_nth (λq. ¬ Option.is_none q) (rs' @ [r]) (length rs') = length ss"
            using l snoc(2, 7, 8, 9) False unfolding *
            by (auto simp: filter_rev_nth_def)
          ultimately show ?thesis using l snoc(2, 7, 9) snoc(11-)[of ?i]
            by (auto simp: nth_append *)
        qed
      qed simp
      then have "ts = map the (filter (λt. ¬ Option.is_none t) (map gcollapse ts''))"
        by (metis comp_the_Some list.map_id map_map)
      then show ?case using ps(1, 2) ts''(1, 2) GFun(3)
        by (auto simp: collapse_automaton_def intro!: exI[of _ "GFun (Some f) ts''"] exI[of _ qs] exI[of _ p])
    qed
    then have "t ∈ the ` (gcollapse ` gta_lang Q A - {None})"
      by (meson Diff_iff gta_langI imageI q(1) singletonD)
  } moreover
  { fix t assume t: "t ∈ gta_lang Q A" "gcollapse t ≠ None"
    obtain q where q: "q |∈| Q" "q |∈| ta_der A (term_of_gterm t)" using t(1) by auto
    have "q |∈| ta_der (collapse_automaton A) (term_of_gterm (the (gcollapse t)))" using q(2) t(2)
    proof (induct t arbitrary: q)
      case (GFun f ts)
      obtain qs q' where q: "TA_rule f qs q' |∈| rules A" "q' = q ∨ (q', q) |∈| (eps (collapse_automaton A))|+|"
        "length qs = length ts" "⋀i. i < length ts ⟹ qs ! i |∈| ta_der A (term_of_gterm (ts ! i))"
        using GFun(2) by (auto simp: collapse_automaton_def)
      obtain f' where f [simp]: "f = Some f'" using GFun(3) by (cases f) auto
      define qs' where
        "qs' = map (λi. if Option.is_none (gcollapse (ts ! i)) then None else Some (qs ! i)) [0..<length qs]"
      have "Option.is_none (gcollapse (ts ! i)) ⟹ qs ! i |∈| Qn'" if "i < length qs" for i
        using q(4)[of i] that
        by (cases "ts ! i" rule: gcollapse.cases)
           (auto simp: q(3) Qn'_def fmember.rep_eq collapse_Qn_Qs_set_conv, meson notin_fset ta_der_Fun)
      moreover have "¬ Option.is_none (gcollapse (ts ! i)) ⟹ qs ! i |∈| Qs'" if "i < length qs" for i
        using q(4)[of i] that
        by (cases "ts ! i" rule: gcollapse.cases)
           (auto simp: q(3) Qs'_def fmember.rep_eq collapse_Qn_Qs_set_conv, meson notin_fset ta_der_Fun)
      ultimately have "f' (map the (filter (λq. ¬ Option.is_none q) qs')) → q' |∈| rules (collapse_automaton A)"
        using q(1, 4) unfolding collapse_automaton_def Qn'_def[symmetric] Qs'_def[symmetric]
        by (fastforce simp: qs'_def q(3) intro: exI[of _ qs] exI[of _ qs'] split: if_splits)
      moreover have ***: "length (filter (λi.¬ Option.is_none (gcollapse (ts ! i))) [0..<length ts]) =
        length (filter (λt. ¬ Option.is_none (gcollapse t)) ts)" for ts
        by (subst length_map[of "(!) ts", symmetric] filter_map[unfolded comp_def, symmetric] map_nth)+
          (rule refl)
      note this[of ts]
      moreover have "the (filter (λq. ¬ Option.is_none q) qs' ! i) |∈| ta_der (collapse_automaton A)
        (term_of_gterm (the (filter (λt. ¬ Option.is_none t) (map gcollapse ts) ! i)))"
        if "i < length [x←ts . ¬ Option.is_none (gcollapse x)]" for i
        unfolding qs'_def using that q(3) GFun(1)[OF nth_mem q(4)]
      proof (induct ts arbitrary: qs rule: List.rev_induct)
        case (snoc t ts)
        have x1 [simp]: "i < length xs ⟹ (xs @ ys) ! i = xs ! i" for xs ys i by (auto simp: nth_append)
        have x2: "i = length xs ⟹ (xs @ ys) ! i = ys ! 0" for xs ys i by (auto simp: nth_append)
        obtain q qs' where qs [simp]: "qs = qs' @ [q]" using snoc(3) by (cases "rev qs") auto
        have [simp]:
          "map (λx. if Option.is_none (gcollapse ((ts @ [t]) ! x)) then None else Some ((qs' @ [q]) ! x)) [0..<length ts] =
           map (λx. if Option.is_none (gcollapse (ts ! x)) then None else Some (qs' ! x)) [0..<length ts]"
          using snoc(3) by auto
        show ?case
        proof (cases "Option.is_none (gcollapse t)")
          case True then show ?thesis using snoc(1)[of qs'] snoc(2,3)
            snoc(4)[unfolded length_append list.size add_0 add_0_right add_Suc_right, OF less_SucI]
            by (auto cong: if_cong)
        next
          case False note False' = this
          show ?thesis
          proof (cases "i = length [x←ts . ¬ Option.is_none (gcollapse x)]")
            case True
            then show ?thesis using snoc(3) snoc(4)[of "length ts"]
              unfolding qs length_append list.size add_0 add_0_right add_Suc_right
                upt_Suc_append[OF zero_le] filter_append map_append
              by (subst (5 6) x2) (auto simp: comp_def *** False' Option.is_none_def[symmetric])
          next
            case False
            then show ?thesis using snoc(1)[of qs'] snoc(2,3)
              snoc(4)[unfolded length_append list.size add_0 add_0_right add_Suc_right, OF less_SucI]
              unfolding qs length_append list.size add_0 add_0_right add_Suc_right
                upt_Suc_append[OF zero_le] filter_append map_append
              by (subst (5 6) x1) (auto simp: comp_def *** False')
          qed
        qed
      qed auto
      ultimately show ?case using q(2) by (auto simp: qs'_def comp_def q(3)
        intro!: exI[of _ q'] exI[of _ "map the (filter (λq. ¬ Option.is_none q) qs')"])
    qed
    then have "the (gcollapse t) ∈ gta_lang Q (collapse_automaton A)"
      by (metis q(1) gta_langI)
  } ultimately show ?thesis by blast
qed

lemma ℒ_collapse_automaton':
  assumes "𝒬r A |⊆| ta_reachable (ta A)" (* cf. ta_trim *)
  shows "ℒ (collapse_automaton_reg A) = the ` (gcollapse ` ℒ A - {None})"
  using assms by (auto simp: collapse_automaton_reg_def ℒ_def collapse_automaton')

lemma collapse_automaton:
  assumes "𝒬r A |⊆| ta_reachable (ta A)" "RR1_spec A T"
  shows "RR1_spec (collapse_automaton_reg A) (the ` (gcollapse ` ℒ A - {None}))"
  using collapse_automaton'[OF assms(1)] assms(2)
  by (simp add: collapse_automaton_reg_def ℒ_def RR1_spec_def)


subsection ‹Cylindrification›

(* cylindrification is a product ("pairing") of a RR1 language accepting all terms, and an RRn language,
modulo some fairly trivial renaming of symbols. *)

definition pad_with_Nones where
  "pad_with_Nones n m = (λ(f, g). case_option (replicate n None) id f @ case_option (replicate m None) id g)"

lemma gencode_append:
  "gencode (ss @ ts) = map_gterm (pad_with_Nones (length ss) (length ts)) (gpair (gencode ss) (gencode ts))"
proof -
  have [simp]: "p ∉ gposs (gunions (map gdomain ts)) ⟹ map (λt. gfun_at t p) ts = replicate (length ts) None"
    for p ts by (intro nth_equalityI) 
        (fastforce simp: poss_gposs_mem_conv fun_at_def' image_def all_set_conv_all_nth)+
  note [simp] = glabel_map_gterm_conv[of "λ(_ :: unit option). ()", unfolded comp_def gdomain_id]
  show ?thesis by (auto intro!: arg_cong[of _ _ "λx. glabel x _"] simp del: gposs_gunions
    simp: pad_with_Nones_def gencode_def gunions_append gpair_def map_gterm_glabel comp_def)
qed

lemma append_automaton:
  assumes "RRn_spec n A T" "RRn_spec m B U"
  shows "RRn_spec (n + m) (fmap_funs_reg (pad_with_Nones n m) (pair_automaton_reg A B)) {ts @ us |ts us. ts ∈ T ∧ us ∈ U}"
  using assms pair_automaton[of A "gencode ` T" B "gencode ` U"]
  unfolding RRn_spec_def
proof (intro conjI set_eqI iffI, goal_cases)
  case (1 s)
  then obtain ts us where "ts ∈ T" "us ∈ U" "s = gencode (ts @ us)"
    by (fastforce simp: ℒ_def fmap_funs_reg_def RR1_spec_def RR2_spec_def gencode_append fmap_funs_gta_lang)
  then show ?case by blast
qed (fastforce simp: RR1_spec_def RR2_spec_def fmap_funs_reg_def ℒ_def gencode_append fmap_funs_gta_lang)+

lemma cons_automaton:
  assumes "RR1_spec A T" "RRn_spec m B U"
  shows "RRn_spec (Suc m) (fmap_funs_reg (λ(f, g). pad_with_Nones 1 m (map_option (λf. [Some f]) f, g))
   (pair_automaton_reg A B)) {t # us |t us. t ∈ T ∧ us ∈ U}"
proof -
  have [simp]: "{ts @ us |ts us. ts ∈ (λt. [t]) ` T ∧ us ∈ U} = {t # us |t us. t ∈ T ∧ us ∈ U}"
    by (auto intro: exI[of _ "[_]", OF exI])
  show ?thesis using append_automaton[OF RR1_to_RRn_spec, OF assms]
    by (auto simp: ℒ_def fmap_funs_reg_def pair_automaton_reg_def comp_def
      fmap_funs_gta_lang map_pair_automaton_12 fmap_funs_ta_comp prod.case_distrib
      gencode_append[of "[_]", unfolded gencode_singleton List.append.simps])
qed

subsection ‹Projection›

(* projection is composed from fmap_funs_ta and collapse_automaton, corresponding to gsnd *)

abbreviation "drop_none_rule m fs ≡ if list_all (Option.is_none) (drop m fs) then None else Some (drop m fs)"

lemma drop_automaton_reg:
  assumes "𝒬r A |⊆| ta_reachable (ta A)" "m < n" "RRn_spec n A T"
  defines "f ≡ λfs. drop_none_rule m fs"
  shows "RRn_spec (n - m) (collapse_automaton_reg (fmap_funs_reg f A)) (drop m ` T)"
proof -
  have [simp]: "length ts = n - m ==> p ∈ gposs (gencode ts) ⟹ ∃f. ∃t∈set ts. Some f = gfun_at t p" for p ts
  proof (cases p, goal_cases Empty PCons)
    case Empty
    obtain t where "t ∈ set ts" using assms(2) Empty(1) by (cases ts) auto
    moreover then obtain f where "Some f = gfun_at t p" using Empty(3) by (cases t rule: gterm.exhaust) auto
    ultimately show ?thesis by auto
  next
    case (PCons i p')
    then have "p ≠ []" by auto
    then show ?thesis using PCons(2)
      by (auto 0 3 simp: gencode_def eq_commute[of "gfun_at _ _" "Some _"] elim!: gfun_at_possE)
  qed
  { fix p ts y assume that: "gfun_at (gencode ts) p = Some y"
    have "p ∈ gposs (gencode ts) ⟹ gfun_at (gencode ts) p = Some (map (λt. gfun_at t p) ts)"
      by (auto simp: gencode_def)
    moreover have "gfun_at (gencode ts) p = Some y ⟹ p ∈ gposs (gencode ts)"
      using gfun_at_nongposs by force
    ultimately have "y = map (λt. gfun_at t p) ts ∧ p ∈ gposs (gencode ts)" by (simp add: that)
  } note [dest!] = this
  have [simp]: "list_all f (replicate n x) ⟷ n = 0 ∨ f x" for f n x by (induct n) auto
  have [dest]: "x ∈ set xs ⟹ list_all f xs ⟹ f x" for f x xs by (induct xs) auto
  have *: "f (pad_with_Nones m' n' z) = snd z"
    if  "fst z = None ∨ fst z ≠ None ∧ length (the (fst z)) = m"
      "snd z = None ∨ snd z ≠ None ∧ length (the (snd z)) = n - m ∧ (∃y. Some y ∈ set (the (snd z)))"
      "m' = m" "n' = n - m" for z m' n'
    using that by (auto simp: f_def pad_with_Nones_def split: option.splits prod.splits)
  { fix ts assume ts: "ts ∈ T" "length ts = n"
    have "gencode (drop m ts) = the (gcollapse (map_gterm f (gencode ts)))"
      "gcollapse (map_gterm f (gencode ts)) ≠ None"
    proof (goal_cases)
      case 1 show ?case
        using ts assms(2)
        apply (subst gsnd_gpair[of "gencode (take m ts)", symmetric])
        apply (subst gencode_append[of "take m ts" "drop m ts", unfolded append_take_drop_id])
        unfolding gsnd_def comp_def gterm.map_comp
        apply (intro arg_cong[where f = "λx. the (gcollapse x)"] gterm.map_cong refl)
        by (subst *) (auto simp: gpair_def set_gterm_gposs_conv image_def)
    next
      case 2
      have [simp]: "gcollapse t = None ⟷ gfun_at t [] = Some None" for t
        by (cases t rule: gcollapse.cases) auto
      obtain t where "t ∈ set (drop m ts)" using ts(2) assms(2) by (cases "drop m ts") auto
      moreover then have "¬ Option.is_none (gfun_at t [])" by (cases t rule: gterm.exhaust) auto
      ultimately show ?case
        by (auto simp: f_def gencode_def list_all_def drop_map)
    qed
  }
  then show ?thesis using assms(3)
    by (fastforce simp: ℒ_def collapse_automaton_reg_def fmap_funs_reg_def
      RRn_spec_def fmap_funs_gta_lang gsnd_def gpair_def gterm.map_comp comp_def
      glabel_map_gterm_conv[unfolded comp_def] assms(1) collapse_automaton')
qed

lemma gfst_collapse_simp:
  "the (gcollapse (map_gterm fst t)) = gfst t"
  by (simp add: gfst_def)

lemma gsnd_collapse_simp:
  "the (gcollapse (map_gterm snd t)) = gsnd t"
  by (simp add: gsnd_def)

definition proj_1_reg where
  "proj_1_reg A = collapse_automaton_reg (fmap_funs_reg fst (trim_reg A))"
definition proj_2_reg where
  "proj_2_reg A = collapse_automaton_reg (fmap_funs_reg snd (trim_reg A))"

lemmas proj_1_reg_simp = proj_1_reg_def collapse_automaton_reg_def fmap_funs_reg_def trim_reg_def
lemmas proj_2_reg_simp = proj_2_reg_def collapse_automaton_reg_def fmap_funs_reg_def trim_reg_def

lemma ℒ_proj_1_reg_collapse:
  "ℒ (proj_1_reg 𝒜) = the ` (gcollapse ` map_gterm fst ` (ℒ 𝒜) - {None})"
proof -
  have "𝒬r (fmap_funs_reg fst (trim_reg 𝒜)) |⊆| ta_reachable (ta (fmap_funs_reg fst (trim_reg 𝒜)))"
    by (auto simp: fmap_funs_reg_def)
  note [simp] = ℒ_collapse_automaton'[OF this]
  show ?thesis by (auto simp: proj_1_reg_def fmap_funs_ℒ ℒ_trim)
qed

lemma ℒ_proj_2_reg_collapse:
  "ℒ (proj_2_reg 𝒜) = the ` (gcollapse ` map_gterm snd ` (ℒ 𝒜) - {None})"
proof -
  have "𝒬r (fmap_funs_reg snd (trim_reg 𝒜)) |⊆| ta_reachable (ta (fmap_funs_reg snd (trim_reg 𝒜)))"
    by (auto simp: fmap_funs_reg_def)
  note [simp] = ℒ_collapse_automaton'[OF this]
  show ?thesis by (auto simp: proj_2_reg_def fmap_funs_ℒ ℒ_trim)
qed

lemma proj_1:
  assumes "RR2_spec A R"
  shows "RR1_spec (proj_1_reg A) (fst ` R)"
proof -
  {fix s t assume ass: "(s, t) ∈ R"
    from ass have s: "s = the (gcollapse (map_gterm fst (gpair s t)))"
      by (auto simp: gfst_gpair gfst_collapse_simp)
    then have "Some s = gcollapse (map_gterm fst (gpair s t))"
      by (cases s; cases t) (auto simp: gpair_def)
    then have "s ∈ ℒ (proj_1_reg A)" using assms ass s
      by (auto simp: proj_1_reg_simp ℒ_def trim_ta_reach trim_gta_lang
        image_def image_Collect RR2_spec_def fmap_funs_gta_lang
        collapse_automaton'[of "fmap_funs_ta fst (trim_ta (fin A) (ta A))"])
         force}
  moreover
  {fix s assume "s ∈ ℒ (proj_1_reg A)" then have "s ∈ fst ` R" using assms
      by (auto simp: gfst_collapse_simp gfst_gpair rev_image_eqI RR2_spec_def trim_ta_reach trim_gta_lang
        ℒ_def proj_1_reg_simp fmap_funs_gta_lang collapse_automaton'[of "fmap_funs_ta fst (trim_ta (fin A) (ta A))"])}
  ultimately show ?thesis using assms unfolding RR2_spec_def RR1_spec_def ℒ_def proj_1_reg_simp
    by auto
qed

lemma proj_2:
  assumes "RR2_spec A R"
  shows "RR1_spec (proj_2_reg A) (snd ` R)"
proof -
  {fix s t assume ass: "(s, t) ∈ R"
    then have s: "t = the (gcollapse (map_gterm snd (gpair s t)))"
      by (auto simp: gsnd_gpair gsnd_collapse_simp)
    then have "Some t = gcollapse (map_gterm snd (gpair s t))"
      by (cases s; cases t) (auto simp: gpair_def)
    then have "t ∈ ℒ (proj_2_reg A)" using assms ass s
      by (auto simp: ℒ_def trim_ta_reach trim_gta_lang proj_2_reg_simp
        image_def image_Collect RR2_spec_def fmap_funs_gta_lang
        collapse_automaton'[of "fmap_funs_ta snd (trim_ta (fin A) (ta A))"])
        fastforce}
  moreover
  {fix s assume "s ∈ ℒ (proj_2_reg A)" then have "s ∈ snd ` R" using assms
      by (auto simp: ℒ_def gsnd_collapse_simp gsnd_gpair rev_image_eqI RR2_spec_def
        trim_ta_reach trim_gta_lang proj_2_reg_simp
        fmap_funs_gta_lang collapse_automaton'[of "fmap_funs_ta snd (trim_ta (fin A) (ta A))"])}
  ultimately show ?thesis using assms unfolding RR2_spec_def RR1_spec_def
    by auto
qed

lemma ℒ_proj:
  assumes "RR2_spec A R"
  shows "ℒ (proj_1_reg A) = gfst ` ℒ A" "ℒ (proj_2_reg A) = gsnd ` ℒ A"
proof -
  have [simp]: "gfst ` {gpair t u |t u. (t, u) ∈ R} = fst ` R"
    by (force simp: gfst_gpair image_def)
  have [simp]: "gsnd ` {gpair t u |t u. (t, u) ∈ R} = snd ` R"
    by (force simp: gsnd_gpair image_def)
  show "ℒ (proj_1_reg A) = gfst ` ℒ A" "ℒ (proj_2_reg A) = gsnd ` ℒ A"
    using proj_1[OF assms] proj_2[OF assms] assms gfst_gpair gsnd_gpair
    by (auto simp: RR1_spec_def RR2_spec_def)
qed

lemmas proj_automaton_gta_lang = proj_1 proj_2

subsection ‹Permutation›

(* permutations are a direct application of fmap_funs_ta *)

lemma gencode_permute:
  assumes "set ps = {0..<length ts}"
  shows "gencode (map ((!) ts) ps) = map_gterm (λxs. map ((!) xs) ps) (gencode ts)"
proof -
  have *: "(!) ts ` set ps = set ts" using assms by (auto simp: image_def set_conv_nth)
  show ?thesis using subsetD[OF equalityD1[OF assms]]
    apply (intro eq_gterm_by_gposs_gfun_at)
    unfolding gencode_def gposs_glabel gposs_map_gterm gposs_gunions gfun_at_map_gterm gfun_at_glabel
      set_map * by auto
qed

lemma permute_automaton:
  assumes "RRn_spec n A T" "set ps = {0..<n}"
  shows "RRn_spec (length ps) (fmap_funs_reg (λxs. map ((!) xs) ps) A) ((λxs. map ((!) xs) ps) ` T)"
  using assms by (auto simp: RRn_spec_def gencode_permute fmap_funs_reg_def ℒ_def fmap_funs_gta_lang image_def)


subsection ‹Intersection›

(* intersection is already defined in IsaFoR *)

lemma intersect_automaton:
  assumes "RRn_spec n A T" "RRn_spec n B U"
  shows "RRn_spec n (reg_intersect A B) (T ∩ U)" using assms
  by (simp add: RRn_spec_def ℒ_intersect)
     (metis gdecode_gencode image_Int inj_on_def)

(*
lemma swap_union_automaton:
  "fmap_states_ta (case_sum Inr Inl) (union_automaton B A) = union_automaton A B"
  by (simp add: fmap_states_ta_def' union_automaton_def image_Un image_comp case_sum_o_inj
    ta_rule.map_comp prod.map_comp comp_def id_def ac_simps)
*)

lemma union_automaton:
  assumes "RRn_spec n A T" "RRn_spec n B U"
  shows "RRn_spec n (reg_union A B) (T ∪ U)"
  using assms by (auto simp: RRn_spec_def ℒ_union)

subsection ‹Difference›

lemma RR1_difference:
  assumes "RR1_spec A T" "RR1_spec B U"
  shows "RR1_spec (difference_reg A B) (T - U)"
  using assms by (auto simp: RR1_spec_def ℒ_difference_reg)

lemma RR2_difference:
  assumes "RR2_spec A T" "RR2_spec B U"
  shows "RR2_spec (difference_reg A B) (T - U)"
  using assms by (auto simp: RR2_spec_def ℒ_difference_reg)

lemma RRn_difference:
  assumes "RRn_spec n A T" "RRn_spec n B U"
  shows "RRn_spec n (difference_reg A B) (T - U)"
  using assms by (auto simp: RRn_spec_def ℒ_difference_reg) (metis gdecode_gencode)+

subsection ‹All terms over a signature›

definition term_automaton :: "('f × nat) fset ⇒ (unit, 'f) ta" where
  "term_automaton ℱ = TA ((λ (f, n). TA_rule f (replicate n ()) ()) |`| ℱ) {||}"
definition term_reg where
  "term_reg ℱ = Reg {|()|} (term_automaton ℱ)"

lemma term_automaton:
  "RR1_spec (term_reg ℱ) (𝒯G (fset ℱ))"
  unfolding RR1_spec_def gta_lang_def term_reg_def ℒ_def
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr t)
  then have "() |∈| ta_der (term_automaton ℱ) (term_of_gterm t)"
    by (auto simp: gta_der_def)
  then show ?case
    by (induct t) (auto simp: term_automaton_def split: if_splits simp flip: fmember.rep_eq)
next
  case (rl t)
  then have "() |∈| ta_der (term_automaton ℱ) (term_of_gterm t)"
  proof (induct t rule: 𝒯G.induct)
    case (const a) then show ?case
      by (auto simp: term_automaton_def fimage_iff simp flip: fmember.rep_eq intro: fBexI[of _ "(a, 0)"])
  next
    case (ind f n ss) then show ?case
      by (auto simp: term_automaton_def fimage_iff simp flip: fmember.rep_eq intro: fBexI[of _ "(f, n)"])
  qed
  then show ?case
    by (auto simp: gta_der_def)
qed

fun true_RRn :: "('f × nat) fset ⇒ nat ⇒ (nat, 'f option list) reg" where
  "true_RRn ℱ 0 = Reg {|0|} (TA {|TA_rule [] [] 0|} {||})"
| "true_RRn ℱ (Suc 0) = relabel_reg (fmap_funs_reg (λf. [Some f]) (term_reg ℱ))"
| "true_RRn ℱ (Suc n) = relabel_reg
  (trim_reg (fmap_funs_reg (pad_with_Nones 1 n) (pair_automaton_reg (true_RRn ℱ 1) (true_RRn ℱ n))))"

lemma true_RRn_spec:
  "RRn_spec n (true_RRn ℱ n) {ts. length ts = n ∧ set ts ⊆ 𝒯G (fset ℱ)}"
proof (induct ℱ n rule: true_RRn.induct)
  case (1 ℱ) show ?case
    by (simp cong: conj_cong add: true_RR0_spec)
next
  case (2 ℱ)
  moreover have "{ts. length ts = 1 ∧ set ts ⊆ 𝒯G (fset ℱ)} = (λt. [t]) ` 𝒯G (fset ℱ)"
    apply (intro equalityI subsetI)
    subgoal for ts by (cases ts) auto
    by auto
  ultimately show ?case
    using RR1_to_RRn_spec[OF term_automaton, of ℱ] by auto
next
  case (3 ℱ n)
  have [simp]: "{ts @ us |ts us. length ts = n ∧ set ts ⊆ 𝒯G (fset ℱ) ∧ length us = m ∧
    set us ⊆ 𝒯G (fset ℱ)} = {ss. length ss = n + m ∧ set ss ⊆ 𝒯G (fset ℱ)}" for n m
    by (auto 0 4 intro!: exI[of _ "take n _", OF exI[of _ "drop n _"], of _ xs xs for xs]
      dest!: subsetD[OF set_take_subset] subsetD[OF set_drop_subset])
  show ?case using append_automaton[OF 3]
    by simp
qed


subsection ‹RR2 composition›

abbreviation "RR2_to_RRn A ≡ fmap_funs_reg (λ(f, g). [f, g]) A"
abbreviation "RRn_to_RR2 A ≡ fmap_funs_reg (λf. (f ! 0, f ! 1)) A"
definition rr2_compositon where
  "rr2_compositon ℱ A B =
   (let A' = RR2_to_RRn A in
    let B' = RR2_to_RRn B in
    let F = true_RRn ℱ 1 in
    let CA = trim_reg (fmap_funs_reg (pad_with_Nones 2 1) (pair_automaton_reg A' F)) in
    let CB = trim_reg (fmap_funs_reg (pad_with_Nones 1 2) (pair_automaton_reg F B')) in
    let PI = trim_reg (fmap_funs_reg (λxs. map ((!) xs) [1, 0, 2]) (reg_intersect CA CB)) in
    RRn_to_RR2 (collapse_automaton_reg (fmap_funs_reg (drop_none_rule 1) PI))
   )"

lemma list_length1E:
  assumes "length xs = Suc 0" obtains x where "xs = [x]" using assms
  by (cases xs) auto

lemma rr2_compositon:
  assumes "ℛ ⊆ 𝒯G (fset ℱ) × 𝒯G (fset ℱ)" "𝔏 ⊆ 𝒯G (fset ℱ) × 𝒯G (fset ℱ)"
    and "RR2_spec A ℛ" and "RR2_spec B 𝔏"
  shows "RR2_spec (rr2_compositon ℱ A B) (ℛ O 𝔏)"
proof -
  let ?R = "(λ(t, u). [t, u]) ` ℛ" let ?L = "(λ(t, u). [t, u]) ` 𝔏"
  let ?A = "RR2_to_RRn A" let ?B = "RR2_to_RRn B" let ?F = "true_RRn ℱ 1"
  let ?CA = "trim_reg (fmap_funs_reg (pad_with_Nones 2 1) (pair_automaton_reg ?A ?F))"
  let ?CB = "trim_reg (fmap_funs_reg (pad_with_Nones 1 2) (pair_automaton_reg ?F ?B))"
  let ?PI = "trim_reg (fmap_funs_reg (λxs. map ((!) xs) [1, 0, 2]) (reg_intersect ?CA ?CB))"
  let ?DR = "collapse_automaton_reg (fmap_funs_reg (drop_none_rule 1) ?PI)"
  let ?Rs = "{ts @ us | ts us. ts ∈ ?R ∧ (∃t. us = [t] ∧ t ∈ 𝒯G (fset ℱ))}"
  let ?Ls = "{us @ ts | ts us. ts ∈ ?L ∧ (∃t. us = [t] ∧ t ∈ 𝒯G (fset ℱ))}"
  from RR2_to_RRn_spec assms(3, 4)
  have rr2: "RRn_spec 2 ?A ?R" "RRn_spec 2 ?B ?L" by auto
  have *: "{ts. length ts = 1 ∧ set ts ⊆ 𝒯G (fset ℱ)} = {[t] | t. t ∈ 𝒯G (fset ℱ)}"
    by (auto elim!: list_length1E)
  have F: "RRn_spec 1 ?F {[t] | t. t ∈ 𝒯G (fset ℱ)}" using true_RRn_spec[of 1 ℱ] unfolding * .
  have "RRn_spec 3 ?CA ?Rs" "RRn_spec 3 ?CB ?Ls"
    using append_automaton[OF rr2(1) F] append_automaton[OF F rr2(2)]
    by (auto simp: numeral_3_eq_3) (smt Collect_cong)
  from permute_automaton[OF intersect_automaton[OF this], of "[1, 0, 2]"]
  have "RRn_spec 3 ?PI ((λxs. map ((!) xs) [1, 0, 2]) ` (?Rs ∩ ?Ls))"
    by (auto simp: atLeast0_lessThan_Suc insert_commute numeral_2_eq_2 numeral_3_eq_3)
  from drop_automaton_reg[OF _ _ this, of 1]
  have sp: "RRn_spec 2 ?DR (drop 1 ` (λxs. map ((!) xs) [1, 0, 2]) ` (?Rs ∩ ?Ls))"
    by auto
  {fix s assume "s ∈ (λ(t, u). [t, u]) ` (ℛ O 𝔏)"
    then obtain t u v where comp: "s = [t, u]" "(t, v) ∈ ℛ" "(v, u) ∈ 𝔏"
      by (auto simp: image_iff relcomp_unfold split!: prod.split)
    then have "[t, v] ∈ ?R" "[v , u] ∈ ?L" "u ∈ 𝒯G (fset ℱ)" "v ∈ 𝒯G (fset ℱ)" "t ∈ 𝒯G (fset ℱ)" using assms(1, 2)
      by (auto simp: image_iff relcomp_unfold split!: prod.splits)
    then have "[t, v, u] ∈ ?Rs" "[t, v, u] ∈ ?Ls"
      apply (simp_all)
      subgoal
        apply (rule exI[of _ "[t, v]"], rule exI[of _ "[u]"])
        apply simp
        done
      subgoal
        apply (rule exI[of _ "[v, u]"], rule exI[of _ "[t]"])
        apply simp
        done
      done
    then have "s ∈ drop 1 ` (λxs. map ((!) xs) [1, 0, 2]) ` (?Rs ∩ ?Ls)" unfolding comp(1)
      apply (simp add: image_def Bex_def)
      apply (rule exI[of _ "[v, t, u]"]) apply simp
      apply (rule exI[of _ "[t, v, u]"]) apply simp
      done}
  moreover have "drop 1 ` (λxs. map ((!) xs) [1, 0, 2]) ` (?Rs ∩ ?Ls) ⊆ (λ(t, u). [t, u]) ` (ℛ O 𝔏)"
    by (auto simp: image_iff relcomp_unfold Bex_def split!: prod.splits)
  ultimately have *: "drop 1 ` (λxs. map ((!) xs) [1, 0, 2]) ` (?Rs ∩ ?Ls) = (λ(t, u). [t, u]) ` (ℛ O 𝔏)"
    by (simp add: subsetI subset_antisym)
  have **: "(λf. (f ! 0, f ! 1)) ` (λ(t, u). [t, u]) ` (ℛ O 𝔏) = ℛ O 𝔏"
    by (force simp: image_def relcomp_unfold split!: prod.splits)
  show ?thesis using sp unfolding *
    using RRn_to_RR2_spec[where ?T = "(λ(t, u). [t, u]) ` (ℛ O 𝔏)" and ?A = ?DR]
    unfolding ** by (auto simp: rr2_compositon_def Let_def image_iff)
qed

end
dy>

Theory RR2_Infinite

theory RR2_Infinite
  imports RRn_Automata Tree_Automata_Pumping
begin


lemma map_ta_rule_id [simp]: "map_ta_rule f id r = (r_root r) (map f (r_lhs_states r)) → (f (r_rhs r))" for f r
  by (simp add: ta_rule.expand ta_rule.map_sel(1 - 3))

(* Finitness/Infinitness facts *)

lemma no_upper_bound_infinite:
  assumes "∀(n::nat). ∃t ∈ S. n < f t"
  shows "infinite S"
proof (rule ccontr, simp)
  assume "finite S"
  then obtain n where "n = Max (f ` S)" "∀ t ∈ S. f t ≤ n" by auto
  then show False using assms linorder_not_le by blast
qed

lemma set_constr_finite:
  assumes "finite F"
  shows "finite {h x | x. x ∈ F ∧ P x}" using assms
  by (induct) auto

lemma bounded_depth_finite:
  assumes fin_F: "finite ℱ" and "⋃ (funas_term ` S) ⊆ ℱ"
    and "∀t ∈ S. depth t ≤ n" and "∀t ∈ S. ground t"
  shows "finite S" using assms(2-)
proof (induction n arbitrary: S)
  case 0
  {fix t assume elem: "t ∈ S"
    from 0 have "depth t = 0" "ground t" "funas_term t ⊆ ℱ" using elem by auto
    then have "∃ f. (f, 0) ∈ ℱ ∧ t = Fun f []" by (cases t rule: depth.cases) auto}
  then have "S ⊆ {Fun f [] |f . (f, 0) ∈ ℱ}" by (auto simp add: image_iff)
  from finite_subset[OF this] show ?case
    using set_constr_finite[OF fin_F, of "λ (f, n). Fun f []" "λ x. snd x = 0"]
    by auto
next
  case (Suc n)
  from Suc obtain S' where
    S: "S' = {t :: ('a, 'b) term . ground t ∧ funas_term t ⊆ ℱ ∧ depth t ≤ n}" "finite S'"
    by (auto simp add: SUP_le_iff)
  then obtain L F where L: "set L = S'" "set F = ℱ" using fin_F by (meson finite_list)
  let ?Sn = "{Fun f ts | f ts. (f, length ts) ∈ ℱ ∧ set ts ⊆ S'}"
  let ?Ln = "concat (map (λ (f, n). map (λ ts. Fun f ts) (List.n_lists n L)) F)"
  {fix t assume elem: "t ∈ S"
    from Suc have "depth t ≤ Suc n" "ground t" "funas_term t ⊆ ℱ" using elem by auto
    then have "funas_term t ⊆ ℱ ∧ (∀ x ∈ set (args t). depth x ≤ n) ∧ ground t"
      by (cases t rule: depth.cases) auto
    then have "t ∈ ?Sn ∪ S'"
      using S by (cases t) auto} note sub = this
  {fix t assume elem: "t ∈ ?Sn"
    then obtain f ts where [simp]: "t = Fun f ts" and invar: "(f, length ts) ∈ ℱ" "set ts ⊆ S'"
      by blast
    then have "Fun f ts ∈ set (map (λ ts. Fun f ts) (List.n_lists (length ts) L))" using L(1)
      by (auto simp: image_iff set_n_lists)
    then have "t ∈ set ?Ln" using invar(1) L(2) by auto}
  from this sub have sub: "?Sn ⊆ set ?Ln" "S ⊆ ?Sn ∪ S'" by blast+
  from finite_subset[OF sub(1)] finite_subset[OF sub(2)] finite_UnI[of ?Sn, OF _ S(2)]
  show ?case by blast
qed

lemma infinite_imageD:
  "infinite (f ` S) ⟹ inj_on f S ⟹ infinite S"
  by blast

lemma infinite_imageD2:
  "infinite (f ` S) ⟹ inj f ⟹ infinite S"
  by blast

lemma infinite_inj_image_infinite:
  assumes "infinite S" and "inj_on f S"
  shows "infinite (f ` S)"
  using assms finite_image_iff by blast

(*The following lemma tells us that number of terms greater than a certain depth are infinite*)
lemma infinte_no_depth_limit:
  assumes "infinite S" and "finite ℱ"
    and "∀t ∈ S. funas_term t ⊆ ℱ" and "∀t ∈ S. ground t"
  shows "∀(n::nat). ∃t ∈ S. n < (depth t)"
proof(rule allI, rule ccontr)
  fix n::nat
  assume "¬ (∃t ∈ S. (depth t) >  n)"
  hence "∀t ∈ S. depth t ≤ n" by auto
  from bounded_depth_finite[OF assms(2) _ this] show False using assms
    by auto
qed

lemma depth_gterm_conv:
  "depth (term_of_gterm t) = depth (term_of_gterm t)"
  by (metis leD nat_neq_iff poss_gposs_conv poss_length_bounded_by_depth poss_length_depth)

lemma funs_term_ctxt [simp]:
  "funs_term C⟨s⟩ = funs_ctxt C ∪ funs_term s"
  by (induct C) auto

lemma pigeonhole_ta_infinit_terms:
  fixes t ::"'f gterm" and 𝒜 :: "('q, 'f) ta"
  defines "t' ≡ term_of_gterm t :: ('f, 'q) term"
  assumes "fcard (𝒬 𝒜) < depth t'" and "q |∈| gta_der 𝒜 t" and "P (funas_gterm t)"
  shows "infinite {t . q |∈| gta_der 𝒜 t ∧ P (funas_gterm t)}"
proof -
  from pigeonhole_tree_automata[OF _ assms(3)[unfolded gta_der_def]] assms(2,4)
  obtain C C2 s v p where ctxt: "C2 ≠ □" "C⟨s⟩ = t'" "C2⟨v⟩ = s" and
    loop: "p |∈| ta_der 𝒜 v" "p |∈| ta_der 𝒜 C2⟨Var p⟩" "q |∈| ta_der 𝒜 C⟨Var p⟩"
    unfolding assms(1) by auto
  let ?terms = "λ n. C⟨(C2 ^n)⟨v⟩⟩" let ?inner = "λ n. (C2 ^n)⟨v⟩"
  have gr: "ground_ctxt C2" "ground_ctxt C" "ground v"
    using arg_cong[OF ctxt(2), of ground] unfolding ctxt(3)[symmetric] assms(1)
    by fastforce+
  moreover have funas: "funas_term (?terms (Suc n)) = funas_term t'" for n
    unfolding ctxt(2, 3)[symmetric] using ctxt_comp_n_pres_funas by auto
  moreover have der: "q |∈| ta_der 𝒜 (?terms (Suc n))" for n using loop
    by (meson ta_der_ctxt ta_der_ctxt_n_loop)
  moreover have "n < depth (?terms (Suc n))" for n
    by (meson ctxt(1) ctxt_comp_n_lower_bound depth_ctxt_less_eq less_le_trans)
  ultimately have "q |∈| ta_der 𝒜 (?terms (Suc n)) ∧ ground (?terms (Suc n)) ∧
    P (funas_term (?terms (Suc n))) ∧ n < depth (?terms (Suc n))" for n using assms(4)
    by (auto simp: assms(1) funas_term_of_gterm_conv)
  then have inf: "infinite {t. q |∈| ta_der 𝒜 t ∧ ground t ∧ P (funas_term t)}"
    by (intro no_upper_bound_infinite[of _ depth]) blast
  have inj: "inj_on gterm_of_term {t. q |∈| ta_der 𝒜 t ∧ ground t ∧ P (funas_term t)}"
    by (intro gterm_of_term_inj) simp
  show ?thesis
    by (intro infinite_super[OF _ infinite_inj_image_infinite[OF inf inj]])
       (auto simp: image_def gta_der_def funas_gterm_gterm_of_term)
qed


lemma gterm_to_None_Some_funas [simp]:
  "funas_gterm (gterm_to_None_Some t) ⊆ (λ (f, n). ((None, Some f), n)) ` ℱ ⟷ funas_gterm t ⊆ ℱ"
  by (induct t) (auto simp: funas_gterm_def, blast)

lemma funas_gterm_bot_some_decomp:
  assumes "funas_gterm s ⊆ (λ (f, n). ((None, Some f), n)) ` ℱ"
  shows "∃ t. gterm_to_None_Some t = s ∧ funas_gterm t ⊆ ℱ" using assms
proof (induct s)
  case (GFun f ts)
  from GFun(1)[OF nth_mem] obtain ss where l: "length ss = length ts ∧ (∀i<length ts. gterm_to_None_Some (ss ! i) = ts ! i)"
    using Ex_list_of_length_P[of "length ts" "λ s i. gterm_to_None_Some s = ts ! i"] GFun(2-)
    by (auto simp: funas_gterm_def) (meson UN_subset_iff nth_mem)
  then have "i < length ss ⟹ funas_gterm (ss ! i) ⊆ ℱ" for i using GFun(2)
    by (auto simp: UN_subset_iff) (smt (z3) gterm_to_None_Some_funas nth_mem subsetD)
  then show ?case using GFun(2-) l
    by (cases f) (force simp: map_nth_eq_conv UN_subset_iff dest!: in_set_idx intro!: exI[of _ "GFun (the (snd f)) ss"])
qed

(* Definition INF, Q_infinity and automata construction *)

definition "Inf_branching_terms ℛ ℱ = {t . infinite {u. (t, u) ∈ ℛ ∧ funas_gterm u ⊆ fset ℱ} ∧ funas_gterm t ⊆ fset ℱ}"

definition "Q_infty 𝒜 ℱ = {|q | q. infinite {t | t. funas_gterm t ⊆ fset ℱ ∧ q |∈| ta_der 𝒜 (term_of_gterm (gterm_to_None_Some t))}|}"

lemma Q_infty_fmember:
  "q |∈| Q_infty 𝒜 ℱ ⟷ infinite {t | t. funas_gterm t ⊆ fset ℱ ∧ q |∈| ta_der 𝒜 (term_of_gterm (gterm_to_None_Some t))}"
proof -
  have "{q | q. infinite {t | t. funas_gterm t ⊆ fset ℱ ∧ q |∈| ta_der 𝒜 (term_of_gterm (gterm_to_None_Some t))}} ⊆ fset (𝒬 𝒜)"
    using not_finite_existsD notin_fset by fastforce
  from finite_subset[OF this] show ?thesis
    by (auto simp: Q_infty_def)
qed

abbreviation q_inf_dash_intro_rules where
  "q_inf_dash_intro_rules Q r ≡ if (r_rhs r) |∈| Q ∧ fst (r_root r) = None then {|(r_root r) (map CInl (r_lhs_states r)) → CInr (r_rhs r)|} else {||}"

abbreviation args :: "'a list ⇒ nat ⇒ ('a + 'a) list" where
  "args ≡ λ qs i. map CInl (take i qs) @ CInr (qs ! i) # map CInl (drop (Suc i) qs)"

abbreviation q_inf_dash_closure_rules :: "('q, 'f) ta_rule ⇒ ('q + 'q, 'f) ta_rule list" where
  "q_inf_dash_closure_rules r ≡ (let (f, qs, q) = (r_root r, r_lhs_states r, r_rhs r) in
   (map (λ i. f (args qs i) → CInr q) [0 ..< length qs]))"

definition Inf_automata :: "('q, 'f option × 'f option) ta ⇒ 'q fset ⇒ ('q + 'q, 'f option × 'f option) ta" where
  "Inf_automata 𝒜 Q = TA
  (( |⋃| (q_inf_dash_intro_rules Q |`| rules 𝒜)) |∪| ( |⋃| ((fset_of_list ∘ q_inf_dash_closure_rules) |`| rules 𝒜)) |∪|
   map_ta_rule CInl id |`| rules 𝒜) (map_both Inl |`| eps 𝒜 |∪| map_both CInr |`| eps 𝒜)"

definition Inf_reg where
  "Inf_reg 𝒜 Q = Reg (CInr |`| fin 𝒜) (Inf_automata (ta 𝒜) Q)"

lemma Inr_Inl_rel_comp:
  "map_both CInr |`| S |O| map_both CInl |`| S = {||}" by auto

lemmas eps_split = ftrancl_Un2_separatorE[OF Inr_Inl_rel_comp]

lemma Inf_automata_eps_simp [simp]:
  shows "(map_both Inl |`| eps 𝒜 |∪| map_both CInr |`| eps 𝒜)|+| =
      (map_both CInl |`| eps 𝒜)|+| |∪| (map_both CInr |`| eps 𝒜)|+|"
proof -
  {fix x y z assume "(x, y) |∈| (map_both CInl |`| eps 𝒜)|+|"
    "(y, z) |∈| (map_both CInr |`| eps 𝒜)|+|"
    then have False
      by (metis Inl_Inr_False eps_statesI(1, 2) eps_states_image fimageE ftranclD ftranclD2)}
  then show ?thesis by (auto simp: Inf_automata_def eps_split)
qed

lemma map_both_CInl_ftrancl_conv:
  "(map_both CInl |`| eps 𝒜)|+| = map_both CInl |`| (eps 𝒜)|+|"
  by (intro ftrancl_map_both_fsubset) (auto simp: finj_CInl_CInr)

lemma map_both_CInr_ftrancl_conv:
  "(map_both CInr |`| eps 𝒜)|+| = map_both CInr |`| (eps 𝒜)|+|"
  by (intro ftrancl_map_both_fsubset) (auto simp: finj_CInl_CInr)

lemmas map_both_ftrancl_conv = map_both_CInl_ftrancl_conv map_both_CInr_ftrancl_conv 

lemma Inf_automata_Inl_to_eps [simp]:
  "(CInl p, CInl q) |∈| (map_both CInl |`| eps 𝒜)|+| ⟷ (p, q) |∈| (eps 𝒜)|+|"
  "(CInr p, CInr q) |∈| (map_both CInr |`| eps 𝒜)|+| ⟷ (p, q) |∈| (eps 𝒜)|+|"
  "(CInl q, CInl p) |∈| (map_both CInr |`| eps 𝒜)|+| ⟷ False"
  "(CInr q, CInr p) |∈| (map_both CInl |`| eps 𝒜)|+| ⟷ False"
  by (auto simp: map_both_ftrancl_conv dest: fmap_prod_fimageI)

lemma Inl_eps_Inr:
  "(CInl q, CInl p) |∈| (eps (Inf_automata 𝒜 Q))|+| ⟷ (CInr q, CInr p) |∈| (eps (Inf_automata 𝒜 Q))|+|"
  by (auto simp: Inf_automata_def)

lemma Inr_rhs_eps_Inr_lhs:
  assumes "(q, CInr p) |∈| (eps (Inf_automata 𝒜 Q))|+|"
  obtains q' where "q = CInr q'" using assms ftrancl_map_both_fsubset[OF finj_CInl_CInr(1)]
  by (cases q) (auto simp: Inf_automata_def map_both_ftrancl_conv)

lemma Inl_rhs_eps_Inl_lhs:
  assumes "(q, CInl p) |∈| (eps (Inf_automata 𝒜 Q))|+|"
  obtains q' where "q = CInl q'" using assms
  by (cases q) (auto simp: Inf_automata_def map_both_ftrancl_conv)

lemma Inf_automata_eps [simp]:
  "(CInl q, CInr p) |∈| (eps (Inf_automata 𝒜 Q))|+| ⟷ False"
  "(CInr q, CInl p) |∈| (eps (Inf_automata 𝒜 Q))|+| ⟷ False"
  by (auto elim: Inr_rhs_eps_Inr_lhs Inl_rhs_eps_Inl_lhs)

lemma Inl_A_res_Inf_automata:
  "ta_der (fmap_states_ta CInl 𝒜) t |⊆| ta_der (Inf_automata 𝒜 Q) t"
  by (intro ta_der_mono) (auto simp: Inf_automata_def rev_fimage_eqI fmap_states_ta_def')

lemma Inl_res_A_res_Inf_automata:
  "CInl |`| ta_der 𝒜 (term_of_gterm t) |⊆| ta_der (Inf_automata 𝒜 Q) (term_of_gterm t)"
  by (intro fsubset_trans[OF ta_der_fmap_states_ta_mono[of CInl 𝒜 t]]) (auto simp: Inl_A_res_Inf_automata)

lemma r_rhs_CInl_args_A_rule:
  assumes "f qs → CInl q |∈| rules (Inf_automata 𝒜 Q)"
  obtains qs' where "qs = map CInl qs'" "f qs' → q |∈| rules 𝒜" using assms
  by (auto simp: Inf_automata_def split!: if_splits)

lemma A_rule_to_dash_closure:
  assumes "f qs → q |∈| rules 𝒜" and "i < length qs"
  shows "f (args qs i) → CInr q |∈| rules (Inf_automata 𝒜 Q)"
  using assms by (auto simp add: Inf_automata_def fimage_iff fBall_def upt_fset intro!: fBexI[OF _ assms(1)])

lemma Inf_automata_reach_to_dash_reach:
  assumes "CInl p |∈| ta_der (Inf_automata 𝒜 Q) C⟨Var (CInl q)⟩"
  shows "CInr p |∈| ta_der (Inf_automata 𝒜 Q) C⟨Var (CInr q)⟩" (is "_ |∈| ta_der ?A _")
  using assms
proof (induct C arbitrary: p)
  case (More f ss C ts)
  from More(2) obtain qs q' where
    rule: "f qs → q' |∈| rules ?A" "length qs = Suc (length ss + length ts)" and
    eps: "q' = CInl p ∨ (q', CInl p) |∈| (eps ?A)|+|" and
    reach: "∀ i <  Suc (length ss + length ts). qs ! i |∈| ta_der ?A ((ss @ C⟨Var (CInl q)⟩ # ts) ! i)"
    by auto
  from eps obtain q'' where [simp]: "q' = CInl q''"
    by (cases q') (auto simp add: Inf_automata_def eps_split elim: ftranclE converse_ftranclE)
  from rule obtain qs' where args: "qs = map CInl qs'" "f qs' → q'' |∈| rules 𝒜"
    using r_rhs_CInl_args_A_rule by (metis ‹q' = CInl q''›)
  then have "CInl (qs' ! length ss) |∈| ta_der (Inf_automata 𝒜 Q) C⟨Var (CInl q)⟩" using reach
    by (auto simp: all_Suc_conv nth_append_Cons) (metis length_map less_add_Suc1 local.rule(2) nth_append_length nth_map reach) 
  from More(1)[OF this] More(2) show ?case
    using rule args eps reach A_rule_to_dash_closure[OF args(2), of "length ss" Q]
    by (auto simp: Inl_eps_Inr id_take_nth_drop all_Suc_conv
        intro!: exI[of _ "CInr q''"] exI[of _ "map CInl (take (length ss) qs') @ CInr (qs' ! length ss) # map CInl (drop (Suc (length ss)) qs')"])
      (auto simp: nth_append_Cons min_def)
qed (auto simp: Inf_automata_def)

lemma Inf_automata_dashI:
  assumes "run 𝒜 r (gterm_to_None_Some t)" and "ex_rule_state r |∈| Q"
  shows "CInr (ex_rule_state r) |∈| gta_der (Inf_automata 𝒜 Q) (gterm_to_None_Some t)"
proof (cases t)
  case [simp]: (GFun f ts)
  from run_root_rule[OF assms(1)] run_argsD[OF assms(1)] have
    rule: "TA_rule (None, Some f) (map ex_comp_state (gargs r)) (ex_rule_state r) |∈| rules 𝒜" "length (gargs r) = length ts" and
    reach: "∀ i < length ts. ex_comp_state (gargs r ! i) |∈| ta_der 𝒜 (term_of_gterm (gterm_to_None_Some (ts  ! i)))"
    by (auto intro!: run_to_comp_st_gta_der[unfolded gta_der_def comp_def])
  from rule assms(2) have "(None, Some f) (map (CInl ∘ ex_comp_state) (gargs r)) → CInr (ex_rule_state r) |∈| rules  (Inf_automata 𝒜 Q)"
    by (auto simp: Inf_automata_def) force
  then show ?thesis using reach rule Inl_res_A_res_Inf_automata[of 𝒜 "gterm_to_None_Some (ts ! i)" Q for i]
    by (auto simp: gta_der_def intro!: exI[of _ "CInr (ex_rule_state r)"]  exI[of _ "map (CInl ∘ ex_comp_state) (gargs r)"])
        blast
qed

lemma Inf_automata_dash_reach_to_reach:
  assumes "p |∈| ta_der (Inf_automata 𝒜 Q) t" (is "_ |∈| ta_der ?A _")
  shows "remove_sum p |∈| ta_der 𝒜 (map_vars_term remove_sum t)" using assms
proof (induct t arbitrary: p)
  case (Var x) then show ?case
    by (cases p; cases x) (auto simp: Inf_automata_def ftrancl_map_both map_both_ftrancl_conv)
next
  case (Fun f ss)
  from Fun(2) obtain qs q' where
    rule: "f qs → q' |∈| rules ?A" "length qs = length ss" and
    eps: "q' = p ∨ (q', p) |∈| (eps ?A)|+|" and
    reach: "∀ i <  length ss. qs ! i |∈| ta_der ?A (ss ! i)" by auto
  from rule have r: "f (map (remove_sum) qs) → (remove_sum q') |∈| rules 𝒜"
    by (auto simp: comp_def Inf_automata_def min_def id_take_nth_drop[symmetric] upt_fset
             simp flip: drop_map take_map split!: if_splits)
  moreover have "remove_sum q' = remove_sum p ∨ (remove_sum q', remove_sum p) |∈| (eps 𝒜)|+|" using eps
    by (cases "is_Inl q'"; cases "is_Inl p") (auto elim!: is_InlE is_InrE, auto simp: Inf_automata_def)
  ultimately show ?case using reach rule(2) Fun(1)[OF nth_mem, of i "qs ! i" for i]
    by auto (metis (mono_tags, lifting) length_map map_nth_eq_conv)+
qed

lemma depth_poss_split:
  assumes "Suc (depth (term_of_gterm t) + n) < depth (term_of_gterm u)"
  shows "∃ p q. p @ q ∈ gposs u ∧ n < length q ∧ p ∉ gposs t"
proof -
  from poss_length_depth obtain p m where p: "p ∈ gposs u" "length p = m" "depth (term_of_gterm u) = m"
    using poss_gposs_conv by blast
  then obtain m' where dt: "depth (term_of_gterm t) = m'" by blast
  from assms dt p(2, 3) have "length (take (Suc m') p) = Suc m'"
    by (metis Suc_leI depth_gterm_conv length_take less_add_Suc1 less_imp_le_nat less_le_trans min.absorb2)
  then have nt: "take (Suc m') p ∉ gposs t" using poss_length_bounded_by_depth dt depth_gterm_conv
    by (metis Suc_n_not_le_n gposs_to_poss)
  moreover have "n < length (drop (Suc m') p)" using assms depth_gterm_conv dt p(2-)
    by (metis add_Suc diff_diff_left length_drop zero_less_diff) 
  ultimately show ?thesis by (metis append_take_drop_id p(1))
qed

lemma Inf_to_automata:
  assumes "RR2_spec 𝒜 ℛ" and "t ∈ Inf_branching_terms ℛ ℱ"
  shows "∃ u. gpair t u ∈ ℒ (Inf_reg 𝒜 (Q_infty (ta 𝒜) ℱ))" (is "∃ u. gpair t u ∈ ℒ ?B")
proof -
  let ?A = "Inf_automata (ta 𝒜) (Q_infty (ta 𝒜) ℱ)"
  let ?t_of_g = "λ t. term_of_gterm t :: ('b, 'a) term"
  obtain n where depth_card: "depth (?t_of_g t) + fcard (𝒬 (ta 𝒜)) < n" by auto
  from assms(1, 2) have fin: "infinite {u. gpair t u ∈ ℒ 𝒜 ∧ funas_gterm u ⊆ fset ℱ}"
    by (auto simp: RR2_spec_def Inf_branching_terms_def)
  from infinte_no_depth_limit[of "?t_of_g ` {u. gpair t u ∈ ℒ 𝒜 ∧ funas_gterm u ⊆ fset ℱ}" "fset ℱ"] this
  have "∀ n. ∃t ∈ ?t_of_g ` {u. gpair t u ∈ ℒ 𝒜 ∧ funas_gterm u ⊆ fset ℱ}. n < depth t"
    by (simp add: infinite_inj_image_infinite[OF fin] funas_term_of_gterm_conv inj_term_of_gterm)
  from this depth_card obtain u where funas: "funas_gterm u ⊆ fset ℱ" and
    depth: "Suc n < depth (?t_of_g u)" and lang: "gpair t u ∈ ℒ 𝒜" by auto
  have "Suc (depth (term_of_gterm t) + fcard (𝒬 (ta 𝒜))) < depth (term_of_gterm u)"
    using depth depth_card by (metis Suc_less_eq2 depth_gterm_conv less_trans)
  from depth_poss_split[OF this] obtain p q where
    pos: "p @ q ∈ gposs u" "p ∉ gposs t" and card: "fcard (𝒬 (ta 𝒜)) < length q" by auto
  then have gp: "gsubt_at (gpair t u) p = gterm_to_None_Some (gsubt_at u p)"
    using subst_at_gpair_nt_poss_None_Some[of p] by force
  from lang obtain r where r: "run (ta 𝒜) r (gpair t u)" "ex_comp_state r |∈| fin 𝒜"
    unfolding ℒ_def gta_lang_def by (fastforce dest: gta_der_to_run)
  from pos have p_gtu: "p ∈ gposs (gpair t u)" and pu: "p ∈ gposs u"
    using not_gposs_append by auto
  have qinf: "ex_rule_state (gsubt_at r p) |∈| Q_infty (ta 𝒜) ℱ"
    using funas_gterm_gsubt_at_subseteq[OF pu] funas card
    unfolding Q_infty_fmember gta_der_def[symmetric]
    by (intro infinite_super[THEN infinite_imageD2[OF _ inj_gterm_to_None_Some],
     OF _ pigeonhole_ta_infinit_terms[of "ta 𝒜" "gsubt_at (gpair t u) p" _
     "λ t. t ⊆ (λ(f, n). ((None, Some f), n)) ` fset ℱ",
     OF _ run_to_gta_der_gsubt_at(1)[OF r(1) p_gtu]]])
        (auto simp: poss_length_bounded_by_depth[of q] image_iff gp less_le_trans
                   pos(1) poss_gposs_conv pu dest!: funas_gterm_bot_some_decomp)
  from Inf_automata_dashI[OF run_gsubt_cl[OF r(1) p_gtu, unfolded gp] qinf]
  have dashI: "CInr (ex_rule_state (gsubt_at r p)) |∈| gta_der (Inf_automata (ta 𝒜) (Q_infty (ta 𝒜) ℱ)) (gsubt_at (gpair t u) p)"
    unfolding gp[symmetric] .
  have "CInl (ex_comp_state r) |∈| ta_der ?A (ctxt_at_pos (term_of_gterm (gpair t u)) p)⟨Var (CInl (ex_rule_state (gsubt_at r p)))⟩"
    using ta_der_fmap_states_ta[OF run_ta_der_ctxt_split2[OF r(1) p_gtu], of CInl, THEN fsubsetD[OF Inl_A_res_Inf_automata]]
    unfolding replace_term_at_replace_at_conv[OF gposs_to_poss[OF p_gtu]]
    by (auto simp: gterm.map_ident simp flip: map_term_replace_at_dist[OF gposs_to_poss[OF p_gtu]])
  from ta_der_ctxt[OF dashI[unfolded gta_der_def] Inf_automata_reach_to_dash_reach[OF this]]
  have "CInr (ex_comp_state r) |∈| gta_der (Inf_automata (ta 𝒜) (Q_infty (ta 𝒜) ℱ)) (gpair t u)"
    unfolding replace_term_at_replace_at_conv[OF gposs_to_poss[OF p_gtu]]
    unfolding replace_gterm_conv[OF p_gtu]
    by (auto simp: gta_der_def)
  moreover from r(2) have "CInr (ex_comp_state r) |∈| fin (Inf_reg 𝒜 (Q_infty (ta 𝒜) ℱ))"
    by (auto simp: Inf_reg_def)
  ultimately show ?thesis using r(2)
    by (auto simp: ℒ_def gta_der_def Inf_reg_def intro: exI[of _ u])
qed

lemma CInr_Inf_automata_to_q_state:
  assumes "CInr p |∈| ta_der (Inf_automata 𝒜 Q) t" and "ground t"
  shows "∃ C s q. C⟨s⟩ = t ∧ CInr q |∈| ta_der (Inf_automata 𝒜 Q) s ∧ q |∈| Q ∧
    CInr p |∈| ta_der (Inf_automata 𝒜 Q) C⟨Var (CInr q)⟩ ∧
    (fst ∘ fst ∘ the ∘ root) s = None" using assms
proof (induct t arbitrary: p)
  case (Fun f ts)
  let ?A = "(Inf_automata 𝒜 Q)"
  from Fun(2) obtain qs q' where
    rule: "f qs → CInr q' |∈| rules ?A" "length qs = length ts" and
    eps: "q' = p ∨ (CInr q', CInr p) |∈| (eps ?A)|+|" and
    reach: "∀ i < length ts. qs ! i |∈| ta_der ?A (ts ! i)"
    by auto (metis Inr_rhs_eps_Inr_lhs)
  consider (a) "⋀ i. i < length qs ⟹ ∃ q''. qs ! i = CInl q''" | (b) "∃ i < length qs. ∃ q''. qs ! i = CInr q''"
    by (meson remove_sum.cases)
  then show ?case
  proof cases
    case a
    then have "f qs → CInr q' |∈| |⋃| (q_inf_dash_intro_rules Q |`| rules 𝒜)" using rule
      by (auto simp: Inf_automata_def min_def upt_fset split!: if_splits)
         (metis (no_types, lifting) Inl_Inr_False Suc_pred append_eq_append_conv id_take_nth_drop
               length_Cons length_drop length_greater_0_conv length_map
               less_nat_zero_code list.size(3) nth_append_length rule(2))
   then show ?thesis using reach eps rule
     by (intro exI[of _ Hole] exI[of _ "Fun f ts"] exI[of _ q'])
         (auto split!: if_splits)
  next
    case b
    then obtain i q'' where b: "i < length ts" "qs ! i = CInr q''" using rule(2) by auto
    then have "CInr q'' |∈| ta_der ?A (ts ! i)" using rule(2) reach by auto 
    from Fun(3) Fun(1)[OF nth_mem, OF b(1) this] b rule(2) obtain C s q''' where
      ctxt: "C⟨s⟩ = ts ! i" and
      qinf: "CInr q''' |∈| ta_der (Inf_automata 𝒜 Q) s ∧ q''' |∈| Q" and
      reach2: "CInr q'' |∈| ta_der (Inf_automata 𝒜 Q) C⟨Var (CInr q''')⟩" and
      "(fst ∘ fst ∘ the ∘ root) s = None"
      by auto
    then show ?thesis using rule eps reach ctxt qinf reach2 b(1) b(2)[symmetric]
      by (auto simp: min_def nth_append_Cons simp flip: map_append id_take_nth_drop[OF b(1)]
        intro!: exI[of _ "More f (take i ts) C (drop (Suc i) ts)"] exI[of _ "s"] exI[of _ "q'''"] exI[of _ "CInr q'"] exI[of _ "qs"])
  qed
qed auto

lemma aux_lemma:
  assumes "RR2_spec 𝒜 ℛ" and "ℛ ⊆ 𝒯G (fset ℱ) × 𝒯G (fset ℱ)"
    and "infinite {u | u. gpair t u ∈ ℒ 𝒜}"
  shows "t ∈ Inf_branching_terms ℛ ℱ"
proof -
  from assms have [simp]: "gpair t u ∈ ℒ 𝒜 ⟷ (t, u) ∈ ℛ ∧ u ∈ 𝒯G (fset ℱ)"
    for u by (auto simp: RR2_spec_def)
  from assms have "t ∈ 𝒯G (fset ℱ)" unfolding RR2_spec_def
    by (auto dest: not_finite_existsD)
  then show ?thesis using assms unfolding Inf_branching_terms_def
    by (auto simp: 𝒯G_equivalent_def)
qed

lemma Inf_automata_to_Inf:
  assumes "RR2_spec 𝒜 ℛ" and "ℛ ⊆ 𝒯G (fset ℱ) × 𝒯G (fset ℱ)"
    and "gpair t u ∈ ℒ (Inf_reg 𝒜 (Q_infty (ta 𝒜) ℱ))"
  shows "t ∈ Inf_branching_terms ℛ ℱ"
proof -
  let ?con = "λ t. term_of_gterm (gterm_to_None_Some t)"
  let ?A = "Inf_automata (ta 𝒜) (Q_infty (ta 𝒜) ℱ)"
  from assms(3) obtain q where fin: "q |∈| fin 𝒜" and
    reach_fin: "CInr q |∈| ta_der ?A (term_of_gterm (gpair t u))"
    by (auto simp: Inf_reg_def ℒ_def Inf_automata_def elim!: gta_langE)
  from CInr_Inf_automata_to_q_state[OF reach_fin] obtain C s p where
    ctxt: "C⟨s⟩ = term_of_gterm (gpair t u)" and
    q_inf_st: "CInr p |∈| ta_der ?A s" "p |∈| Q_infty (ta 𝒜) ℱ" and
    reach: "CInr q |∈| ta_der ?A C⟨Var (CInr p)⟩" and
    none: "(fst ∘ fst ∘ the ∘ root) s = None" by auto
  have gr: "ground s" "ground_ctxt C" using arg_cong[OF ctxt, of ground]
    by auto
  have reach: "q |∈| ta_der (ta 𝒜) (adapt_vars_ctxt C)⟨Var p⟩"
    using gr Inf_automata_dash_reach_to_reach[OF reach]
    by (auto simp: map_vars_term_ctxt_apply)
  from q_inf_st(2) have inf: "infinite {v. funas_gterm v ⊆ fset ℱ ∧ p |∈| ta_der (ta 𝒜) (?con v)}"
    by (simp add: Q_infty_fmember)
  have inf: "infinite {v. funas_gterm v ⊆ fset ℱ ∧ q |∈| gta_der (ta 𝒜) (gctxt_of_ctxt C)⟨gterm_to_None_Some v⟩G}"
    using reach ground_ctxt_adapt_ground[OF gr(2)] gr
    by (intro infinite_super[OF _ inf], auto simp: gta_der_def)
       (smt (z3) adapt_vars_ctxt adapt_vars_term_of_gterm ground_gctxt_of_ctxt_apply_gterm ta_der_ctxt)
  have *: "gfun_at (gterm_of_term C⟨s⟩) (hole_pos C) = gfun_at (gterm_of_term s) []"
    by (induct C) (auto simp: nth_append_Cons)
  from arg_cong[OF ctxt, of "λ t. gfun_at (gterm_of_term t) (hole_pos C)"] none
  have hp_nt: "ghole_pos (gctxt_of_ctxt C) ∉ gposs t" unfolding ground_hole_pos_to_ghole[OF gr(2)]
    using gfun_at_gpair[of t u "hole_pos C"] gr *
    by (cases s) (auto simp flip: poss_gposs_mem_conv split: if_splits elim: gfun_at_possE)
  from gpair_ctxt_decomposition[OF hp_nt, of u "gsubt_at u (hole_pos C)"]
  have to_gpair: "gpair t (gctxt_at_pos u (hole_pos C))⟨v⟩G = (gctxt_of_ctxt C)⟨gterm_to_None_Some v⟩G" for v
    unfolding ground_hole_pos_to_ghole[OF gr(2)] using ctxt gr
    using subst_at_gpair_nt_poss_None_Some[OF _ hp_nt, of u]
    by (metis (no_types, lifting) UnE ‹ghole_pos (gctxt_of_ctxt C) = hole_pos C›
        gposs_of_gpair gsubt_at_gctxt_apply_ghole hole_pos_in_ctxt_apply hp_nt poss_gposs_conv term_of_gterm_ctxt_apply)
  have inf: "infinite {v. gpair t ((gctxt_at_pos u (hole_pos C))⟨v⟩G) ∈ ℒ 𝒜}" using fin
    by (intro infinite_super[OF _ inf]) (auto simp: ℒ_def gta_der_def simp flip: to_gpair)
  have "infinite {u |u. gpair t u ∈ ℒ 𝒜}"
    by (intro infinite_super[OF _ infinite_inj_image_infinite[OF inf gctxt_apply_inj_on_term[of "gctxt_at_pos u (hole_pos C)"]]])
       (auto simp: image_def intro: infinite_super)
  then show ?thesis using assms(1, 2)
    by (intro aux_lemma[of 𝒜]) simp
qed

lemma Inf_automata_subseteq:
  "ℒ (Inf_reg 𝒜 (Q_infty (ta 𝒜) ℱ)) ⊆ ℒ 𝒜" (is "ℒ ?IA ⊆ _")
proof
  fix s assume l: "s ∈ ℒ ?IA"
  then obtain q where w: "q |∈| fin ?IA" "q |∈| ta_der (ta ?IA) (term_of_gterm s)"
    by (auto simp: ℒ_def elim!: gta_langE)
  from w(1) have "remove_sum q |∈| fin 𝒜"
    by (auto simp: Inf_reg_def Inf_automata_def)
  then show "s ∈ ℒ 𝒜" using Inf_automata_dash_reach_to_reach[of q "ta 𝒜"] w(2)
    by (auto simp: gterm.map_ident ℒ_def Inf_reg_def)
       (metis gta_langI map_vars_term_term_of_gterm)
qed

lemma ℒ_Inf_reg:
  assumes "RR2_spec 𝒜 ℛ" and "ℛ ⊆ 𝒯G (fset ℱ) × 𝒯G (fset ℱ)"
  shows "gfst ` ℒ (Inf_reg 𝒜 (Q_infty (ta 𝒜) ℱ)) = Inf_branching_terms ℛ ℱ"
proof -
  {fix s assume ass: "s ∈ ℒ (Inf_reg 𝒜 (Q_infty (ta 𝒜) ℱ))"
    then have "∃ t u. s = gpair t u" using Inf_automata_subseteq[of 𝒜 ℱ] assms(1)
      by (auto simp: RR2_spec_def)
    then have "gfst s ∈ Inf_branching_terms ℛ ℱ"
      using ass Inf_automata_to_Inf[OF assms]
      by (force simp: gfst_gpair)}
  then show ?thesis using Inf_to_automata[OF assms(1), of _ ℱ]
    by (auto simp: gfst_gpair) (metis gfst_gpair image_iff)
qed
end
>

Theory Tree_Automata_Abstract_Impl

theory Tree_Automata_Abstract_Impl
  imports Tree_Automata_Det Horn_Fset
begin

section ‹Computing state derivation›

lemma ta_der_Var_code [code]:
  "ta_der 𝒜 (Var q) = finsert q ((eps 𝒜)|+| |``| {|q|})"
  by (auto)

lemma ta_der_Fun_code [code]:
  "ta_der 𝒜 (Fun f ts) =
     (let args = map (ta_der 𝒜) ts in
      let P = (λ r. case r of TA_rule g ps p ⇒ f = g ∧ list_all2 fmember ps args) in
      let S = r_rhs |`| ffilter P (rules 𝒜) in
         S |∪| (eps 𝒜)|+| |``| S)" (is "?Ls = ?Rs")
proof
  {fix q assume "q |∈| ?Ls" then have "q |∈| ?Rs"
      by (auto simp: Let_def ffmember_filter fimage_iff fBex_def list_all2_conv_all_nth fImage_iff
               split!: ta_rule.splits) force}
  then show "?Ls |⊆| ?Rs" by blast
next
  {fix q assume "q |∈| ?Rs" then have "q |∈| ?Ls"
      apply (auto simp: Let_def ffmember_filter fimage_iff fBex_def list_all2_conv_all_nth fImage_iff
                  split!: ta_rule.splits)
      apply (metis ta_rule.collapse)
      apply blast
      done}
  then show "?Rs |⊆| ?Ls" by blast
qed

definition eps_free_automata where
  "eps_free_automata epscl 𝒜 =
  (let ruleps = (λ r. finsert (r_rhs r) (epscl |``| {|r_rhs r|})) in
   let rules = (λ r. (λ q. TA_rule (r_root r) (r_lhs_states r) q) |`| (ruleps r)) |`| (rules 𝒜) in
   TA ( |⋃| rules) {||})"

lemma eps_free [code]:
  "eps_free 𝒜 = eps_free_automata ((eps 𝒜)|+|) 𝒜"
  apply (intro TA_equalityI)
   apply (auto simp: eps_free_def eps_free_rulep_def eps_free_automata_def)
  using fBex_def apply fastforce
  apply (metis ta_rule.exhaust_sel)+
  done


lemma eps_of_eps_free_automata [simp]:
  "eps (eps_free_automata S 𝒜) = {||}"
  by (auto simp add: eps_free_automata_def)

lemma eps_free_automata_empty [simp]:
  "eps 𝒜 = {||} ⟹ eps_free_automata {||} 𝒜 = 𝒜"
  by (auto simp add: eps_free_automata_def intro!: TA_equalityI)

section ‹Computing the restriction of tree automata to state set›

lemma ta_restrict [code]:
  "ta_restrict 𝒜 Q =
     (let rules =  ffilter (λ r. case r of TA_rule f ps p ⇒ fset_of_list ps |⊆| Q ∧ p |∈| Q) (rules 𝒜) in
      let eps = ffilter (λ r. case r of (p, q) ⇒ p |∈| Q ∧ q |∈| Q) (eps 𝒜) in
      TA rules eps)"
  by (auto simp: Let_def ta_restrict_def split!: ta_rule.splits intro: finite_subset[OF _ finite_Collect_ta_rule])


section ‹Computing the epsilon transition for the product automaton›

lemma prod_eps[code_unfold]:
  "fCollect (prod_epsLp 𝒜 ℬ) = (λ ((p, q), r). ((p, r), (q, r))) |`| (eps 𝒜 |×| 𝒬 ℬ)"
  "fCollect (prod_epsRp 𝒜 ℬ) = (λ ((p, q), r). ((r, p), (r, q))) |`| (eps ℬ |×| 𝒬 𝒜)"
  by (auto simp: finite_prod_epsLp prod_epsLp_def finite_prod_epsRp prod_epsRp_def fimage_iff fBex_def)

section ‹Computing reachability›

inductive_set ta_reach for 𝒜 where
   rule [intro]: "f qs → q |∈| rules 𝒜 ⟹ ∀ i < length qs. qs ! i ∈ ta_reach 𝒜 ⟹ q ∈ ta_reach 𝒜"
 |  eps [intro]: "q ∈ ta_reach 𝒜 ⟹ (q, r) |∈| eps 𝒜 ⟹ r ∈ ta_reach 𝒜"


lemma ta_reach_eps_transI:
  assumes "(p, q) |∈| (eps 𝒜)|+|" "p ∈ ta_reach 𝒜"
  shows "q ∈ ta_reach 𝒜" using assms
  by (induct rule: ftrancl_induct) auto

lemma ta_reach_ground_term_der:
  assumes "q ∈ ta_reach 𝒜"
  shows "∃ t. ground t ∧ q |∈| ta_der 𝒜 t" using assms
proof (induct)
  case (rule f qs q)
  then obtain ts where "length ts = length qs"
    "∀ i < length qs. ground (ts ! i)"
    "∀ i < length qs. qs ! i |∈| ta_der 𝒜 (ts ! i)"
    using Ex_list_of_length_P[of "length qs" "λ t i. ground t ∧ qs ! i |∈| ta_der 𝒜 t"]
    by auto
  then show ?case using rule(1)
    by (auto dest!: in_set_idx intro!: exI[of _ "Fun f ts"]) blast
qed (auto, meson ta_der_eps)

lemma ground_term_der_ta_reach:
  assumes "ground t" "q |∈| ta_der 𝒜 t"
  shows "q ∈ ta_reach 𝒜" using assms(2, 1)
  by (induct rule: ta_der_induct) (auto simp add: rule ta_reach_eps_transI)

lemma ta_reach_reachable:
  "ta_reach 𝒜 = fset (ta_reachable 𝒜)"
  using ta_reach_ground_term_der[of _ 𝒜]
  using ground_term_der_ta_reach[of _ _ 𝒜]
  unfolding ta_reachable_def
  by (auto simp flip: fmember.rep_eq)


subsection ‹Horn setup for reachable states›
definition "reach_rules 𝒜 =
  {qs →h q | f qs q. TA_rule f qs q |∈| rules 𝒜} ∪
  {[q] →h r | q r. (q, r) |∈| eps 𝒜}"

locale reach_horn =
  fixes 𝒜 :: "('q, 'f) ta"
begin

sublocale horn "reach_rules 𝒜" .

lemma reach_infer0: "infer0 = {q | f q. TA_rule f [] q |∈| rules 𝒜}"
  by (auto simp: horn.infer0_def reach_rules_def)

lemma reach_infer1:
  "infer1 p X = {r | f qs r. TA_rule f qs r |∈| rules 𝒜 ∧ p ∈ set qs ∧ set qs ⊆ insert p X} ∪
   {r | r. (p, r) |∈| eps 𝒜}"
  unfolding reach_rules_def
  by (auto simp: horn.infer1_def simp flip: ex_simps(1))

lemma reach_sound:
  "ta_reach 𝒜 = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p where x: "p = ta_reach 𝒜" by auto
  show ?case using lr unfolding x
  proof (induct)
    case (rule f qs q)
    then show ?case
      by (intro infer[of qs q]) (auto simp: reach_rules_def dest: in_set_idx)
  next
    case (eps q r)
    then show ?case
      by (intro infer[of "[q]" r]) (auto simp: reach_rules_def)
  qed
next
  case (rl x)
  then show ?case
    by (induct) (auto simp: reach_rules_def)
qed
end

subsection ‹Computing productivity›

text ‹First, use an alternative definition of productivity›

inductive_set ta_productive_ind :: "'q fset ⇒ ('q,'f) ta ⇒ 'q set" for P and 𝒜 :: "('q,'f) ta" where
  basic [intro]: "q |∈| P ⟹ q ∈ ta_productive_ind P 𝒜"
| eps [intro]: "(p, q) |∈| (eps 𝒜)|+| ⟹ q ∈ ta_productive_ind P 𝒜 ⟹ p ∈ ta_productive_ind P 𝒜"
| rule: "TA_rule f qs q |∈| rules 𝒜 ⟹ q ∈ ta_productive_ind P 𝒜 ⟹ q' ∈ set qs ⟹ q' ∈ ta_productive_ind P 𝒜"

lemma ta_productive_ind:
  "ta_productive_ind P 𝒜 = fset (ta_productive P 𝒜)" (is "?LS = ?RS")
proof -
  {fix q assume "q ∈ ?LS" then have "q ∈ ?RS"
      by (induct) (auto dest: ta_prod_epsD simp flip: fmember.rep_eq intro: ta_productive_setI,
         metis (full_types) in_set_conv_nth rule_reachable_ctxt_exist ta_productiveI')}
  moreover
  {fix q assume "q ∈ ?RS" note * = this[unfolded fmember.rep_eq[symmetric]]
    from ta_productiveE[OF *] obtain r C where
      reach : "r |∈| ta_der 𝒜 C⟨Var q⟩" and f: "r |∈| P" by auto
    from f have "r ∈ ta_productive_ind P 𝒜" "r |∈| ta_productive P 𝒜"
      by (auto intro: ta_productive_setI)
    then have "q ∈ ?LS" using reach
    proof (induct C arbitrary: q r)
      case (More f ss C ts)
      from iffD1 ta_der_Fun[THEN iffD1, OF More(4)[unfolded ctxt_apply_term.simps]] obtain ps p where
        inv: "f ps → p |∈| rules 𝒜" "p = r ∨ (p, r) |∈| (eps 𝒜)|+|" "length ps = length (ss @ C⟨Var q⟩ # ts)"
             "ps ! length ss |∈| ta_der 𝒜 C⟨Var q⟩"
        by (auto simp: nth_append_Cons split: if_splits)
      then have "p ∈ ta_productive_ind P 𝒜 ⟹ p |∈| ta_der 𝒜 C⟨Var q⟩ ⟹ q ∈ ta_productive_ind P 𝒜" for p
        using More(1) calculation by (auto simp flip: fmember.rep_eq)
      note [intro!] = this[of "ps ! length ss"]
      show ?case using More(2) inv
        by (auto simp flip: fmember.rep_eq simp: nth_append_Cons ta_productive_ind.rule)
           (metis less_add_Suc1 nth_mem ta_productive_ind.simps)
    qed (auto intro: ta_productive_setI)
  }
  ultimately show ?thesis by auto
qed


subsubsection ‹Horn setup for productive states›

definition "productive_rules P 𝒜 = {[] →h q | q. q |∈| P} ∪
  {[r] →h q | q r. (q, r) |∈| eps 𝒜} ∪
  {[q] →h r | f qs q r. TA_rule f qs q |∈| rules 𝒜 ∧ r ∈ set qs}"

locale productive_horn =
  fixes 𝒜 :: "('q, 'f) ta" and P :: "'q fset"
begin

sublocale horn "productive_rules P 𝒜" .

lemma productive_infer0: "infer0 = fset P"
  by (auto simp: productive_rules_def horn.infer0_def simp flip: fmember.rep_eq)

lemma productive_infer1:
  "infer1 p X = {r | r. (r, p) |∈| eps 𝒜} ∪
    {r | f qs r. TA_rule f qs p |∈| rules 𝒜 ∧ r ∈ set qs}"
  unfolding productive_rules_def horn_infer1_union
  by (auto simp add: horn.infer1_def)
     (metis insertCI list.set(1) list.simps(15) singletonD subsetI)

lemma productive_sound:
  "ta_productive_ind P 𝒜 = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr p) then show ?case using lr
  proof (induct)
    case (basic q)
    then show ?case
      by (intro infer[of "[]" q]) (auto simp: productive_rules_def)
  next
    case (eps p q) then show ?case
    proof (induct rule: ftrancl_induct)
      case (Base p q)
      then show ?case using infer[of "[q]" p]
        by (auto simp: productive_rules_def)
    next
      case (Step p q r)
      then show ?case using infer[of "[r]" q]
        by (auto simp: productive_rules_def)
    qed
  next
    case (rule f qs q p)
    then show ?case
      by (intro infer[of "[q]" p]) (auto simp: productive_rules_def)
  qed
next
  case (rl p)
  then show ?case
    by (induct) (auto simp: productive_rules_def ta_productive_ind.rule)
qed
end

subsection ‹Horn setup for power set construction states›

lemma prod_list_exists:
  assumes "fst p ∈ set qs" "set qs ⊆ insert (fst p) (fst ` X)"
  obtains as where "p ∈ set as" "map fst as = qs" "set as ⊆ insert p X"
proof -
  from assms have "qs ∈ lists (fst ` (insert p X))" by blast
  then obtain ts where ts: "map fst ts = qs" "ts ∈ lists (insert p X)"
    by (metis image_iff lists_image)
  then obtain i where mem: "i < length qs" "qs ! i = fst p" using assms(1)
    by (metis in_set_idx)
  from ts have p: "ts[i := p] ∈ lists (insert p X)"
    using set_update_subset_insert by fastforce
  then have "p ∈ set (ts[i := p])" "map fst (ts[i := p]) = qs" "set (ts[i := p]) ⊆ insert p X"
    using mem ts(1)
    by (auto simp add: nth_list_update set_update_memI intro!: nth_equalityI)
  then show ?thesis using that
    by blast
qed

definition "ps_states_rules 𝒜 = {rs →h (Wrapp q) | rs f q.
    q = ps_reachable_states 𝒜 f (map ex rs) ∧ q ≠ {||}}"

locale ps_states_horn =
  fixes 𝒜 :: "('q, 'f) ta"
begin

sublocale horn "ps_states_rules 𝒜" .

lemma ps_construction_infer0: "infer0 =
  {Wrapp q | f q. q = ps_reachable_states 𝒜 f [] ∧ q ≠ {||}}"
    by (auto simp: ps_states_rules_def horn.infer0_def simp flip: fmember.rep_eq)

lemma ps_construction_infer1:
  "infer1 p X = {Wrapp q | f qs q. q = ps_reachable_states 𝒜 f (map ex qs) ∧ q ≠ {||} ∧
   p ∈ set qs ∧ set qs ⊆ insert p X}"
  unfolding ps_states_rules_def horn_infer1_union
  by (auto simp add: horn.infer1_def ps_reachable_states_def comp_def elim!: prod_list_exists) 

lemma ps_states_sound:
  "ps_states_set 𝒜 = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr p) then show ?case using lr
  proof (induct)
    case (1 ps f)
    then have "ps →h (Wrapp (ps_reachable_states 𝒜 f (map ex ps))) ∈ ps_states_rules 𝒜"
      by (auto simp: ps_states_rules_def)
    then show ?case using horn.saturate.simps 1
      by fastforce
  qed
next
  case (rl p)
  then obtain q where "q ∈ saturate" "q = p" by blast
  then show ?case
    by (induct arbitrary: p)
       (auto simp: ps_states_rules_def intro!: ps_states_set.intros)
qed

end

definition ps_reachable_states_cont where
  "ps_reachable_states_cont Δ Δε f ps =
   (let R = ffilter (λ r. case r of TA_rule g qs q ⇒ f = g ∧ list_all2 (|∈|) qs ps) Δ in
    let S = r_rhs |`| R in
    S |∪| Δε|+| |``| S)"

lemma ps_reachable_states [code]:
  "ps_reachable_states (TA Δ Δε) f ps = ps_reachable_states_cont Δ Δε f ps"
  by (auto simp: ps_reachable_states_fmember ps_reachable_states_cont_def Let_def fimage_iff fBex_def
           split!: ta_rule.splits) force+

definition ps_rules_cont where
 "ps_rules_cont 𝒜 Q =
   (let sig = ta_sig 𝒜 in
    let qss = (λ (f, n). (f, n, fset_of_list (List.n_lists n (sorted_list_of_fset Q)))) |`| sig in
    let res = (λ (f, n, Qs). (λ qs. TA_rule f qs (Wrapp (ps_reachable_states 𝒜 f (map ex qs)))) |`| Qs) |`| qss in
      ffilter (λ r. ex (r_rhs r) ≠ {||}) ( |⋃| res))"

lemma ps_rules [code]:
  "ps_rules 𝒜 Q = ps_rules_cont 𝒜 Q"
  using ps_reachable_states_sig finite_ps_rulesp_unfolded[of Q 𝒜]
  unfolding ps_rules_cont_def
  apply (auto simp: fset_of_list_elem ps_rules_def fin_mono ps_rulesp_def
    fimage_iff set_n_lists simp flip: fmember.rep_eq split!: prod.splits dest!: in_set_idx)
  apply fastforce
  apply (meson fmember.rep_eq nth_mem subsetD)
  done

end

Theory Tree_Automata_Class_Instances_Impl

theory Tree_Automata_Class_Instances_Impl
  imports Tree_Automata
   Deriving.Compare_Instances
   Containers.Collection_Order
   Containers.Collection_Eq
   Containers.Collection_Enum
   Containers.Set_Impl
   Containers.Mapping_Impl
begin

derive linorder ta_rule
derive linorder "term"
derive compare "term"
derive (compare) ccompare "term"
derive ceq ta_rule
derive (eq) ceq fset
derive (eq) ceq FSet_Lex_Wrapper
derive (no) cenum ta_rule
derive (no) cenum FSet_Lex_Wrapper
derive ccompare ta_rule
derive (eq) ceq "term" ctxt
derive (no) cenum "term"
derive (rbt) set_impl fset FSet_Lex_Wrapper ta_rule "term"


instantiation fset :: (linorder) compare
begin
definition compare_fset :: "('a fset ⇒ 'a fset ⇒ order)"
  where "compare_fset = (λ A B.
    (let A' = sorted_list_of_fset A in
     let B' = sorted_list_of_fset B in
     if A' < B' then Lt else if B' < A' then Gt else Eq))"
instance
  apply intro_classes apply (auto simp: compare_fset_def comparator_def Let_def split!: if_splits)
  using sorted_list_of_fset_id apply blast+
  done
end

instantiation fset :: (linorder) ccompare
begin
definition ccompare_fset :: "('a fset ⇒ 'a fset ⇒ order) option"
  where "ccompare_fset = Some (λ A B.
    (let A' = sorted_list_of_fset A in
     let B' = sorted_list_of_fset B in
     if A' < B' then Lt else if B' < A' then Gt else Eq))"
instance
  apply intro_classes apply (auto simp: ccompare_fset_def comparator_def Let_def split!: if_splits)
  using sorted_list_of_fset_id apply blast+
  done
end

instantiation FSet_Lex_Wrapper :: (linorder) compare
begin

definition compare_FSet_Lex_Wrapper :: "'a FSet_Lex_Wrapper ⇒ 'a FSet_Lex_Wrapper ⇒ order"
  where "compare_FSet_Lex_Wrapper = (λ A B.
    (let A' = sorted_list_of_fset (ex A) in
     let B' = sorted_list_of_fset (ex B) in
     if A' < B' then Lt else if B' < A' then Gt else Eq))"

instance
  apply intro_classes apply (auto simp: compare_FSet_Lex_Wrapper_def comparator_def Let_def split!: if_splits)
  using sorted_list_of_fset_id
  by (metis FSet_Lex_Wrapper.expand) 
end

instantiation FSet_Lex_Wrapper :: (linorder) ccompare
begin

definition ccompare_FSet_Lex_Wrapper :: "('a FSet_Lex_Wrapper ⇒ 'a FSet_Lex_Wrapper ⇒ order) option"
  where "ccompare_FSet_Lex_Wrapper = Some (λ A B.
    (let A' = sorted_list_of_fset (ex A) in
     let B' = sorted_list_of_fset (ex B) in
     if A' < B' then Lt else if B' < A' then Gt else Eq))"

instance
  apply intro_classes apply (auto simp: ccompare_FSet_Lex_Wrapper_def comparator_def Let_def split!: if_splits)
  using sorted_list_of_fset_id
  by (metis FSet_Lex_Wrapper.expand) 
end

lemma infinite_ta_rule_UNIV[simp, intro]: "infinite (UNIV :: ('q,'f) ta_rule set)"
proof -
  fix f :: 'f
  fix q :: 'q
  let ?map = "λ n. (f (replicate n q) → q)"
  have "inj ?map" unfolding inj_on_def by auto
  from infinite_super[OF _ range_inj_infinite[OF this]]
  show ?thesis by blast
qed

instantiation ta_rule :: (type, type) card_UNIV begin
definition "finite_UNIV = Phantom(('a, 'b) ta_rule) False"
definition "card_UNIV = Phantom(('a, 'b)ta_rule) 0"
instance
  by intro_classes
     (simp_all add: infinite_ta_rule_UNIV card_UNIV_ta_rule_def finite_UNIV_ta_rule_def)
end

instantiation ta_rule :: (ccompare,ccompare)cproper_interval
begin
definition "cproper_interval = (λ ( _ :: ('a,'b)ta_rule option) _ . False)"
instance by (intro_classes, auto)
end

lemma finite_finite_Fpow:
  assumes "finite A"
  shows "finite (Fpow A)" using assms
proof (induct A)
  case (insert x F)
  {fix X assume ass: "X ⊆ insert x F ∧ finite X"
    then have "X - {x} ⊆ F" using ass by auto
    then have fpow :"X - {x} ∈ Fpow F" using conjunct2[OF ass]
       by (auto simp: Fpow_def)
    have "X ∈ Fpow F ∪ insert x ` Fpow F"
    proof (cases "x ∈ X")
      case True
      then have "X ∈ insert x ` Fpow F" using fpow
        by (metis True image_eqI insert_Diff)        
      then show ?thesis by simp
    next
      case False
      then show ?thesis using fpow by simp
    qed}
  then have *: "Fpow (insert x F) = Fpow F ∪ insert x ` Fpow F"
    by (auto simp add: Fpow_def image_def)
  show ?case using insert unfolding *
    by simp
qed (auto simp: Fpow_def)

lemma infinite_infinite_Fpow:
  assumes "infinite A"
  shows "infinite (Fpow A)"
proof -
  have inj: "inj (λ S. {S})" by auto
  have "(λ S. {S}) ` A ⊆ Fpow A" by (auto simp: Fpow_def)
  from finite_subset[OF this] inj assms
  show ?thesis
    by (auto simp: finite_image_iff)
qed

lemma inj_on_Abs_fset:
  "(⋀ X. X ∈ A ⟹ finite X) ⟹ inj_on Abs_fset A" unfolding inj_on_def
  by (auto simp add: Abs_fset_inject)

lemma UNIV_FSet_Lex_Wrapper:
  "(UNIV :: 'a FSet_Lex_Wrapper set) = (Wrapp ∘ Abs_fset) ` (Fpow (UNIV :: 'a set))"
  by (simp add: image_def Fpow_def) (metis (mono_tags, lifting) Abs_fset_cases FSet_Lex_Wrapper.exhaust UNIV_eq_I mem_Collect_eq)

lemma FSet_Lex_Wrapper_UNIV:
  "(UNIV :: 'a FSet_Lex_Wrapper set) = (Wrapp ∘ Abs_fset) ` (Fpow (UNIV :: 'a set))"
  by (simp add: comp_def image_def Fpow_def)
       (metis (mono_tags, lifting) Abs_fset_cases Abs_fset_inverse Collect_cong FSet_Lex_Wrapper.induct iso_tuple_UNIV_I mem_Collect_eq top_set_def)

lemma Wrapp_Abs_fset_inj:
  "inj_on (Wrapp ∘ Abs_fset) (Fpow A)"
  using inj_on_Abs_fset inj_FSet_Lex_Wrapper Fpow_def
  by (auto simp: inj_on_def inj_def)

lemma infinite_FSet_Lex_Wrapper_UNIV:
  assumes "infinite (UNIV :: 'a set)"
  shows "infinite (UNIV :: 'a FSet_Lex_Wrapper set)"
proof -
  let ?FP = "Fpow (UNIV :: 'a set)"
  have "finite ((Wrapp ∘ Abs_fset) ` ?FP) ⟹ finite ?FP"
    using finite_image_iff[OF Wrapp_Abs_fset_inj]
    by (auto simp: inj_on_def inj_def)
  then show ?thesis unfolding FSet_Lex_Wrapper_UNIV using infinite_infinite_Fpow[OF assms]
    by auto
qed

lemma finite_FSet_Lex_Wrapper_UNIV:
  assumes "finite (UNIV :: 'a set)"
  shows "finite (UNIV :: 'a FSet_Lex_Wrapper set)" using assms
  unfolding FSet_Lex_Wrapper_UNIV
  using finite_image_iff[OF Wrapp_Abs_fset_inj]
  using finite_finite_Fpow[OF assms]
  by simp

instantiation FSet_Lex_Wrapper :: (finite_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a FSet_Lex_Wrapper) 
  (of_phantom (finite_UNIV :: 'a finite_UNIV))"
instance using infinite_FSet_Lex_Wrapper_UNIV
  by intro_classes
    (auto simp add: finite_UNIV_FSet_Lex_Wrapper_def finite_UNIV finite_FSet_Lex_Wrapper_UNIV)
end


instantiation FSet_Lex_Wrapper :: (linorder) cproper_interval begin
fun cproper_interval_FSet_Lex_Wrapper :: "'a FSet_Lex_Wrapper option ⇒ 'a FSet_Lex_Wrapper option ⇒ bool"  where
  "cproper_interval_FSet_Lex_Wrapper None None ⟷ True"
| "cproper_interval_FSet_Lex_Wrapper None (Some B) ⟷ (∃ Z. sorted_list_of_fset (ex Z) < sorted_list_of_fset (ex B))"
| "cproper_interval_FSet_Lex_Wrapper (Some A) None ⟷ (∃ Z. sorted_list_of_fset (ex A) < sorted_list_of_fset (ex Z))"
| "cproper_interval_FSet_Lex_Wrapper (Some A) (Some B) ⟷ (∃ Z. sorted_list_of_fset (ex A) < sorted_list_of_fset (ex Z) ∧
    sorted_list_of_fset (ex Z) < sorted_list_of_fset (ex B))"
declare cproper_interval_FSet_Lex_Wrapper.simps [code del]

lemma lt_of_comp_sorted_list [simp]:
  "ID ccompare = Some f ⟹ lt_of_comp f X Z ⟷ sorted_list_of_fset (ex X) < sorted_list_of_fset (ex Z)"
  by (auto simp: lt_of_comp_def ID_code ccompare_FSet_Lex_Wrapper_def Let_def split!: if_splits)

instance by (intro_classes) (auto simp: class.proper_interval_def)
end



lemma infinite_term_UNIV[simp, intro]: "infinite (UNIV :: ('f,'v)term set)"
proof -
  fix f :: 'f and v :: 'v
  let ?inj = "λn. Fun f (replicate n (Var v))"
  have "inj ?inj" unfolding inj_on_def by auto
  from infinite_super[OF _ range_inj_infinite[OF this]]
  show ?thesis by blast
qed

instantiation "term" :: (type,type) finite_UNIV
begin
definition "finite_UNIV = Phantom(('a,'b)term) False"
instance
  by (intro_classes, unfold finite_UNIV_term_def, simp)
end



instantiation "term" :: (compare,compare) cproper_interval
begin
definition "cproper_interval = (λ ( _ :: ('a,'b)term option) _ . False)"
instance by (intro_classes, auto)
end

derive (assoclist) mapping_impl FSet_Lex_Wrapper

end

Theory Tree_Automata_Impl

theory Tree_Automata_Impl
  imports Tree_Automata_Abstract_Impl
   "HOL-Library.List_Lexorder"
   "HOL-Library.AList_Mapping"
   Tree_Automata_Class_Instances_Impl
   Containers.Containers
begin

definition map_val_of_list :: "('b ⇒ 'a) ⇒ ('b ⇒ 'c list) ⇒ 'b list ⇒ ('a, 'c list) mapping" where
  "map_val_of_list ek ev xs = foldr (λx m. Mapping.update (ek x) (ev x @ case_option Nil id (Mapping.lookup m (ek x))) m) xs Mapping.empty"

abbreviation "map_of_list ek ev xs ≡ map_val_of_list ek (λ x. [ev x]) xs"

lemma map_val_of_list_tabulate_conv:
  "map_val_of_list ek ev xs = Mapping.tabulate (sort (remdups (map ek xs))) (λ k. concat (map ev (filter (λ x. k = ek x) xs)))"
  unfolding map_val_of_list_def
proof (induct xs)
  case (Cons x xs) then show ?case
    by (intro mapping_eqI) (auto simp: lookup_combine lookup_update' lookup_empty lookup_tabulate image_iff)
qed (simp add: empty_Mapping tabulate_Mapping)

lemmas map_val_of_list_simp = map_val_of_list_tabulate_conv lookup_tabulate
subsection ‹Setup for the list implementation of reachable states›

definition reach_infer0_cont where
  "reach_infer0_cont Δ =
     map r_rhs (filter (λ r. case r of TA_rule f ps p ⇒ ps = []) (sorted_list_of_fset Δ))"

definition reach_infer1_cont :: "('q :: linorder, 'f :: linorder) ta_rule fset ⇒ ('q × 'q) fset ⇒ 'q ⇒ 'q fset ⇒ 'q list" where
  "reach_infer1_cont Δ Δε =
    (let rules = sorted_list_of_fset Δ in
     let eps   = sorted_list_of_fset Δε in
     let mapp_r = map_val_of_list fst snd (concat (map (λ r. map (λ q. (q, [r])) (r_lhs_states r)) rules)) in
     let mapp_e = map_of_list fst snd eps in
    (λ p bs.
    (map r_rhs (filter (λ r. case r of TA_rule f qs q ⇒
      fset_of_list qs |⊆| finsert p bs) (case_option Nil id (Mapping.lookup mapp_r p)))) @
      case_option Nil id (Mapping.lookup mapp_e p)))"

locale reach_rules_fset =
  fixes Δ :: "('q :: linorder, 'f :: linorder) ta_rule fset" and Δε :: "('q × 'q) fset"
begin

sublocale reach_horn "TA Δ Δε" .

lemma infer1:
  "infer1 p (fset bs) = set (reach_infer1_cont Δ Δε p bs)"
  unfolding reach_infer1 reach_infer1_cont_def set_append Un_assoc[symmetric] Let_def
  unfolding sorted_list_of_fset_simps union_fset
  apply (intro arg_cong2[of _ _ _ _ "(∪)"])
  subgoal
    apply (auto simp: fset_of_list_elem less_eq_fset.rep_eq fset_of_list.rep_eq image_iff
      map_val_of_list_simp fmember.rep_eq split!: ta_rule.splits)
    apply (metis list.set_intros(1) ta_rule.sel(2, 3))
    apply (metis in_set_simps(2) ta_rule.exhaust_sel)
    done
  subgoal
    apply (simp add: image_def Bex_def fmember.rep_eq map_val_of_list_simp)
    done
  done

sublocale l: horn_fset "reach_rules (TA Δ Δε)" "reach_infer0_cont Δ" "reach_infer1_cont Δ Δε"
  apply (unfold_locales)
  unfolding reach_infer0 reach_infer0_cont_def
  subgoal
    apply (auto simp: image_iff ta_rule.case_eq_if Bex_def fset_of_list_elem fmember.rep_eq)
    apply force
    apply (metis ta_rule.collapse)+
    done
  subgoal using infer1
    apply blast
    done
  done

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition "reach_cont_impl Δ Δε =
   horn_fset_impl.saturate_impl (reach_infer0_cont Δ) (reach_infer1_cont Δ Δε)"

lemma reach_fset_impl_sound:
  "reach_cont_impl Δ Δε = Some xs ⟹ fset xs = ta_reach (TA Δ Δε)"
  using reach_rules_fset.saturate_impl_sound unfolding reach_cont_impl_def
  unfolding reach_horn.reach_sound .

lemma reach_fset_impl_complete:
  "reach_cont_impl Δ Δε ≠ None"
proof -
  have "finite (ta_reach (TA Δ Δε))"
    unfolding ta_reach_reachable by simp
  then show ?thesis unfolding reach_cont_impl_def
    by (intro reach_rules_fset.saturate_impl_complete)
      (auto simp: reach_horn.reach_sound)
qed

lemma reach_impl [code]:
  "ta_reachable (TA Δ Δε) = the (reach_cont_impl Δ Δε)"
  using reach_fset_impl_sound[of Δ Δε]
  apply (auto simp add: ta_reach_reachable reach_fset_impl_complete fset_of_list_elem)
  apply (metis fset_inject option.exhaust_sel reach_fset_impl_complete)+
  done

subsection ‹Setup for list implementation of productive states›
definition productive_infer1_cont :: "('q :: linorder, 'f :: linorder) ta_rule fset ⇒ ('q × 'q) fset ⇒ 'q ⇒ 'q fset ⇒ 'q list" where
  "productive_infer1_cont Δ Δε =
    (let rules = sorted_list_of_fset Δ in
     let eps   = sorted_list_of_fset Δε in
     let mapp_r = map_of_list (λ r. r_rhs r) r_lhs_states rules in
     let mapp_e = map_of_list snd fst eps in
    (λ p bs.
     (case_option Nil id (Mapping.lookup mapp_e p)) @
     concat (case_option Nil id (Mapping.lookup mapp_r p))))"

locale productive_rules_fset =
  fixes Δ :: "('q :: linorder, 'f :: linorder) ta_rule fset" and Δε :: "('q × 'q) fset" and P :: "'q fset"
begin

sublocale productive_horn "TA Δ Δε" P .

lemma infer1:
  "infer1 p (fset bs) = set (productive_infer1_cont Δ Δε p bs)"
  unfolding productive_infer1 productive_infer1_cont_def set_append Un_assoc[symmetric]
  unfolding union_fset sorted_list_of_fset_simps Let_def set_append
  apply (intro arg_cong2[of _ _ _ _ "(∪)"])
  subgoal
    apply (simp add: image_def Bex_def fmember.rep_eq map_val_of_list_simp)
    done
  subgoal
    apply (auto simp flip: fmember.rep_eq simp: map_val_of_list_simp image_iff)
    apply (metis ta_rule.sel(2, 3))
    apply (metis ta_rule.collapse)
    apply (metis notin_fset ta_rule.sel(3))
    done
  done

sublocale l: horn_fset "productive_rules P (TA Δ Δε)" "sorted_list_of_fset P" "productive_infer1_cont Δ Δε"
  apply (unfold_locales)
  using infer1 productive_infer0 fset_of_list.rep_eq
  by fastforce+

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition "productive_cont_impl P Δ Δε =
   horn_fset_impl.saturate_impl (sorted_list_of_fset P) (productive_infer1_cont Δ Δε)"

lemma productive_cont_impl_sound:
  "productive_cont_impl P Δ Δε = Some xs ⟹ fset xs = ta_productive_ind P (TA Δ Δε)"
  using productive_rules_fset.saturate_impl_sound unfolding productive_cont_impl_def
  unfolding productive_horn.productive_sound .

lemma productive_cont_impl_complete:
  "productive_cont_impl P Δ Δε ≠ None"
proof -
  have "finite (ta_productive_ind  P (TA Δ Δε))"
    unfolding ta_productive_ind by simp
  then show ?thesis unfolding productive_cont_impl_def
    by (intro productive_rules_fset.saturate_impl_complete)
      (auto simp: productive_horn.productive_sound)
qed

lemma productive_impl [code]:
  "ta_productive P (TA Δ Δε) = the (productive_cont_impl P Δ Δε)"
  using productive_cont_impl_complete[of P Δ] productive_cont_impl_sound[of P Δ]
  by (auto simp add: ta_productive_ind fset_of_list_elem fmember.rep_eq)

subsection ‹Setup for the implementation of power set construction states›


abbreviation "r_statesl r ≡ length (r_lhs_states r)"

definition ps_reachable_states_list where
  "ps_reachable_states_list mapp_r mapp_e f ps =
   (let R = filter (λ r. list_all2 (|∈|) (r_lhs_states r) ps)
      (case_option Nil id (Mapping.lookup mapp_r (f, length ps))) in
    let S = map r_rhs R in
    S @ concat (map (case_option Nil id ∘ Mapping.lookup mapp_e) S))"

lemma ps_reachable_states_list_sound:
  assumes "length ps = n"
  and mapp_r: "case_option Nil id (Mapping.lookup mapp_r (f, n)) =
     filter (λr. r_root r = f ∧ r_statesl r = n) (sorted_list_of_fset Δ)"
  and mapp_e: "⋀p. case_option Nil id (Mapping.lookup mapp_e p) =
     map snd (filter (λ q. fst q = p) (sorted_list_of_fset (Δε|+|)))"
  shows "fset_of_list (ps_reachable_states_list mapp_r mapp_e f (map ex ps)) =
   ps_reachable_states (TA Δ Δε) f (map ex ps)" (is "?Ls = ?Rs")
proof -
  have *: "length ps = n" "length (map ex ps) = n" using assms by auto
  {fix q assume "q |∈| ?Ls"
    then obtain qs p where "TA_rule f qs p |∈| Δ" "length ps = length qs"
       "list_all2 (|∈|) qs (map ex ps)" "p = q ∨ (p, q) |∈| Δε|+|"
      unfolding ps_reachable_states_list_def Let_def comp_def assms(1, 2, 3) *
      by (force simp add: fset_of_list_elem image_iff fBex_def simp flip: fmember.rep_eq) 
    then have "q |∈| ?Rs"
      by (force simp add: ps_reachable_states_fmember image_iff)}
  moreover
    {fix q assume "q |∈| ?Rs"
       then obtain qs p where "TA_rule f qs p |∈| Δ" "length ps = length qs"
         "list_all2 (|∈|) qs (map ex ps)" "p = q ∨ (p, q) |∈| Δε|+|"
         by (auto simp add: ps_reachable_states_fmember list_all2_iff)
       then have "q |∈| ?Ls"
         unfolding ps_reachable_states_list_def Let_def * comp_def assms(2, 3)
         by (force simp add: fset_of_list_elem image_iff simp flip: fmember.rep_eq)}
  ultimately show ?thesis by blast
qed


lemma rule_target_statesI:
  "∃ r |∈| Δ. r_rhs r = q ⟹ q |∈| rule_target_states Δ"
  by auto

definition ps_states_infer0_cont :: "('q :: linorder, 'f :: linorder) ta_rule fset ⇒
   ('q × 'q) fset ⇒ 'q FSet_Lex_Wrapper list" where
   "ps_states_infer0_cont Δ Δε =
     (let sig = filter (λ r. r_lhs_states r = []) (sorted_list_of_fset Δ) in
        filter (λ p. ex p ≠ {||}) (map (λ r. Wrapp (ps_reachable_states (TA Δ Δε) (r_root r) [])) sig))"

definition ps_states_infer1_cont :: "('q :: linorder , 'f :: linorder) ta_rule fset ⇒ ('q × 'q) fset ⇒
   'q FSet_Lex_Wrapper ⇒ 'q FSet_Lex_Wrapper fset ⇒ 'q FSet_Lex_Wrapper list" where
  "ps_states_infer1_cont Δ Δε =
    (let sig = remdups (map (λ r. (r_root r, r_statesl r)) (filter (λ r. r_lhs_states r ≠ []) (sorted_list_of_fset Δ))) in
     let arities = remdups (map snd sig) in
     let etr   = sorted_list_of_fset (Δε|+|) in
     let mapp_r = map_of_list (λ r. (r_root r, r_statesl r)) id (sorted_list_of_fset Δ) in
     let mapp_e = map_of_list fst snd etr in
    (λ p bs.
      (let states = sorted_list_of_fset (finsert p bs) in
       let arity_to_states_map = Mapping.tabulate arities (λ n. list_of_permutation_element_n p n states) in
       let res = map (λ (f, n).
         map (λ s. let rules = the (Mapping.lookup mapp_r (f, n)) in
            Wrapp (fset_of_list (ps_reachable_states_list mapp_r mapp_e f (map ex s))))
           (the (Mapping.lookup arity_to_states_map n)))
          sig in
      filter (λ p. ex p ≠ {||}) (concat res))))"

locale ps_states_fset =
  fixes Δ :: "('q :: linorder, 'f :: linorder) ta_rule fset" and Δε :: "('q × 'q) fset"
begin

sublocale ps_states_horn "TA Δ Δε" .

lemma infer0: "infer0 = set (ps_states_infer0_cont Δ Δε)"
  unfolding ps_states_horn.ps_construction_infer0
  unfolding ps_states_infer0_cont_def Let_def
  using ps_reachable_states_fmember
  by (auto simp add: image_def Ball_def Bex_def)
     (metis fmember.rep_eq list_all2_Nil2 ps_reachable_states_fmember ta.sel(1) ta_rule.sel(1, 2))

lemma r_lhs_states_nConst:
  "r_lhs_states r ≠ [] ⟹ r_statesl r ≠ 0" for r by auto


lemma filter_empty_conv':
  "[] = filter P xs ⟷ (∀x∈set xs. ¬ P x)"
  by (metis filter_empty_conv)

lemma infer1:
  "infer1 p (fset bs) = set (ps_states_infer1_cont Δ Δε p bs)" (is "?Ls = ?Rs")
proof -
  let ?mapp_r = "map_of_list (λr. (r_root r, r_statesl r)) (λx. x) (sorted_list_of_fset Δ)"
  let ?mapp_e = "map_of_list fst snd (sorted_list_of_fset (Δε|+|))"
  have mapr: "case_option Nil id (Mapping.lookup ?mapp_r (f, n)) =
     filter (λr. r_root r = f ∧ r_statesl r = n) (sorted_list_of_fset Δ)" for f n
    by (auto simp: map_val_of_list_simp image_iff filter_empty_conv' intro: filter_cong)
  have epsr: "⋀p. case_option Nil id (Mapping.lookup ?mapp_e p) =
     map snd (filter (λ q. fst q = p) (sorted_list_of_fset (Δε|+|)))"
    by (auto simp: map_val_of_list_simp image_iff filter_empty_conv) metis
  have *: "p ∈ set qs ⟹ x |∈| ps_reachable_states (TA Δ Δε) f (map ex qs) ⟹
    (∃ ps q. TA_rule f ps q |∈| Δ ∧ length ps = length qs)" for x f qs
    by (auto simp: ps_reachable_states_fmember list_all2_conv_all_nth)
  {fix q assume "q ∈ ?Ls"
    then obtain f qss where sp: "q = Wrapp (ps_reachable_states (TA Δ Δε) f (map ex qss))"
      "ps_reachable_states (TA Δ Δε) f (map ex qss) ≠ {||}" "p ∈ set qss" "set qss ⊆ insert p (fset bs)"
      by (auto simp add: ps_construction_infer1 ps_reachable_states_fmember)
    from sp(2, 3) obtain ps p' where r: "TA_rule f ps p' |∈| Δ" "length ps = length qss" using *
      by blast
    then have mem: "qss ∈ set (list_of_permutation_element_n p (length ps) (sorted_list_of_fset (finsert p bs)))" using sp(2-)
      by (auto simp: list_of_permutation_element_n_iff)
         (meson in_set_idx insertE set_list_subset_eq_nth_conv)
    then have "q ∈ ?Rs" using sp r
      unfolding ps_construction_infer1 ps_states_infer1_cont_def Let_def
      apply (simp add: lookup_tabulate ps_reachable_states_fmember image_iff flip: fmember.rep_eq)
      apply (rule_tac x = "f ps → p'" in exI)
      apply (auto simp: Bex_def ps_reachable_states_list_sound[OF _ mapr epsr] intro: exI[of _ qss])
      done}
  moreover
  {fix q assume ass: "q ∈ ?Rs"
    then obtain r qss where "r |∈| Δ" "r_lhs_states r ≠ []" "qss ∈ set (list_of_permutation_element_n p (r_statesl r) (sorted_list_of_fset (finsert p bs)))"
      "q = Wrapp (ps_reachable_states (TA Δ Δε) (r_root r) (map ex qss))"
      unfolding ps_states_infer1_cont_def Let_def
      by (auto simp add: lookup_tabulate ps_reachable_states_fmember image_iff
         ps_reachable_states_list_sound[OF _ mapr epsr] split: if_splits simp flip: fmember.rep_eq)
    moreover have "q ≠ Wrapp {||}" using ass
      by (auto simp: ps_states_infer1_cont_def Let_def)
    ultimately have "q ∈ ?Ls" unfolding ps_construction_infer1
      apply (auto simp: list_of_permutation_element_n_iff intro!: exI[of _ "r_root r"] exI[of _ qss])
      apply (metis in_set_idx)
      done}
  ultimately show ?thesis by blast
qed


sublocale l: horn_fset "ps_states_rules (TA Δ Δε)" "ps_states_infer0_cont Δ Δε" "ps_states_infer1_cont Δ Δε"
  apply (unfold_locales)
  using infer0 infer1
  by fastforce+

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete


end

definition "ps_states_fset_impl Δ Δε =
   horn_fset_impl.saturate_impl (ps_states_infer0_cont Δ Δε) (ps_states_infer1_cont Δ Δε)"

lemma ps_states_fset_impl_sound:
  assumes "ps_states_fset_impl Δ Δε = Some xs"
  shows "xs = ps_states (TA Δ Δε)"
  using ps_states_fset.saturate_impl_sound[OF assms[unfolded ps_states_fset_impl_def]]
  using ps_states_horn.ps_states_sound[of "TA Δ Δε"]
  by (auto simp: fset_of_list_elem fmember.rep_eq ps_states.rep_eq fset_of_list.rep_eq)

lemma ps_states_fset_impl_complete:
  "ps_states_fset_impl Δ Δε ≠ None"
proof -
  let ?R = "ps_states (TA Δ Δε)"
  let ?S = "horn.saturate (ps_states_rules (TA Δ Δε))"
  have "?S ⊆ fset ?R"
    using ps_states_horn.ps_states_sound
    by (simp add: ps_states_horn.ps_states_sound ps_states.rep_eq)
  from finite_subset[OF this] show ?thesis
  unfolding ps_states_fset_impl_def
  by (intro ps_states_fset.saturate_impl_complete) simp
qed

lemma ps_ta_impl [code]:
  "ps_ta (TA Δ Δε) =
    (let xs = the (ps_states_fset_impl Δ Δε) in
      TA (ps_rules (TA Δ Δε) xs) {||})"
  using ps_states_fset_impl_complete
  using ps_states_fset_impl_sound
  unfolding ps_ta_def Let_def
  by (metis option.exhaust_sel)

lemma ps_reg_impl [code]:
  "ps_reg (Reg Q (TA Δ Δε)) =
    (let xs = the (ps_states_fset_impl Δ Δε) in
     Reg (ffilter (λ S. Q |∩| ex S ≠ {||}) xs)
         (TA (ps_rules (TA Δ Δε) xs) {||}))"
  using ps_states_fset_impl_complete[of Δ Δε]
  using ps_states_fset_impl_sound[of Δ Δε]
  unfolding ps_reg_def ps_ta_Qf_def Let_def
  unfolding ps_ta_def Let_def
  using eq_ffilter by auto

lemma prod_ta_zip [code]:
  "prod_ta_rules (𝒜 :: ('q1 :: linorder, 'f :: linorder) ta) (ℬ :: ('q2 :: linorder, 'f :: linorder) ta) =
   (let sig = sorted_list_of_fset (ta_sig 𝒜 |∩| ta_sig ℬ) in
    let mapA = map_of_list (λr. (r_root r, r_statesl r)) id (sorted_list_of_fset (rules 𝒜)) in
    let mapB = map_of_list (λr. (r_root r, r_statesl r)) id (sorted_list_of_fset (rules ℬ)) in
    let merge = (λ (ra, rb). TA_rule (r_root ra) (zip (r_lhs_states ra) (r_lhs_states rb)) (r_rhs ra, r_rhs rb)) in
      fset_of_list (
      concat (map (λ (f, n). map merge
        (List.product (the (Mapping.lookup mapA (f, n))) (the (Mapping.lookup mapB (f, n))))) sig)))"
 (is "?Ls = ?Rs")
proof -
  have [simp]: "distinct (sorted_list_of_fset (ta_sig 𝒜))"  "distinct (sorted_list_of_fset (ta_sig ℬ))"
    by (simp_all add: distinct_sorted_list_of_fset)
  have *: "sort (remdups (map (λr. (r_root r, r_statesl r)) (sorted_list_of_fset (rules 𝒜)))) = sorted_list_of_fset (ta_sig 𝒜)"
   "sort (remdups (map (λr. (r_root r, r_statesl r)) (sorted_list_of_fset (rules ℬ)))) = sorted_list_of_fset (ta_sig ℬ)"
     by (auto simp: ta_sig_def sorted_list_of_fset_fimage_dist)
  {fix r assume ass: "r |∈| ?Ls"
    then obtain f qs q where [simp]: "r = f qs → q" by auto
    then have "(f, length qs) |∈| ta_sig 𝒜 |∩| ta_sig ℬ" using ass by auto
    then have "r |∈| ?Rs" using ass unfolding map_val_of_list_tabulate_conv *
      by (auto simp: Let_def fset_of_list_elem image_iff case_prod_beta lookup_tabulate simp flip: fmember.rep_eq intro!: bexI[of _ "(f, length qs)"])
         (metis (no_types, lifting) length_map ta_rule.sel(1 - 3) zip_map_fst_snd)}
    moreover
    {fix r assume ass: "r |∈| ?Rs" then have "r |∈| ?Ls" unfolding map_val_of_list_tabulate_conv *
        by (auto simp: fset_of_list_elem finite_Collect_prod_ta_rules lookup_tabulate simp flip: fmember.rep_eq)
           (metis ta_rule.collapse)}
  ultimately show ?thesis by blast
qed

(*
export_code ta_der in Haskell
export_code ta_reachable in Haskell
export_code ta_productive in Haskell
export_code trim_ta in Haskell
export_code ta_restrict in Haskell
export_code ps_reachable_states in Haskell
export_code prod_ta_rules in Haskell
export_code ps_ta in Haskell
export_code ps_reg in Haskell
export_code reg_intersect in Haskell
*)

end
head>

Theory RR2_Infinite_Q_infinity

theory RR2_Infinite_Q_infinity
  imports RR2_Infinite
begin

(* This section constructs an executable membership check for Q infinity,
  since Inf_automata is already executable (for all sets Q where checking membership is executable)
*)

lemma if_cong':
  "b = c ⟹ x = u ⟹ y = v ⟹ (if b then x else y) = (if c then u else v)"
  by auto

(* The reachable terms where eps transitions can only occur after the rule *)
fun ta_der_strict :: "('q,'f) ta ⇒ ('f,'q) term ⇒ 'q fset" where
  "ta_der_strict 𝒜 (Var q) = {|q|}"
| "ta_der_strict 𝒜 (Fun f ts) = {| q' | q' q qs. TA_rule f qs q |∈| rules 𝒜 ∧ (q = q' ∨ (q, q') |∈| (eps 𝒜)|+|) ∧ 
    length qs = length ts ∧ (∀ i < length ts. qs ! i |∈| ta_der_strict 𝒜 (ts ! i))|}"

lemma ta_der_strict_Var:
  "q |∈| ta_der_strict 𝒜 (Var x) ⟷ x = q"
  unfolding ta_der.simps by auto

lemma ta_der_strict_Fun:
  "q |∈| ta_der_strict 𝒜 (Fun f ts) ⟷ (∃ ps p. TA_rule f ps p |∈| (rules 𝒜) ∧
      (p = q ∨ (p, q) |∈| (eps 𝒜)|+|) ∧ length ps = length ts ∧ 
      (∀ i < length ts. ps ! i |∈| ta_der_strict 𝒜 (ts ! i)))" (is "?Ls ⟷ ?Rs")
  unfolding ta_der_strict.simps
  by (intro iffI fCollect_memberI finite_Collect_less_eq[OF _ finite_eps[of 𝒜]]) auto

declare ta_der_strict.simps[simp del]
lemmas ta_der_strict_simps [simp] = ta_der_strict_Var ta_der_strict_Fun

lemma ta_der_strict_sub_ta_der:
  "ta_der_strict 𝒜 t |⊆| ta_der 𝒜 t"
proof (induct t)
  case (Fun f ts)
  then show ?case
    by auto (metis fsubsetD nth_mem)+
qed auto
  
lemma ta_der_strict_ta_der_eq_on_ground:
  assumes"ground t"
  shows "ta_der 𝒜 t = ta_der_strict 𝒜 t"
proof
  {fix q assume "q |∈| ta_der 𝒜 t" then have "q |∈| ta_der_strict 𝒜 t" using assms
    proof (induct t arbitrary: q)
      case (Fun f ts)
      then show ?case apply auto
        using nth_mem by blast+
    qed auto}
  then show "ta_der 𝒜 t |⊆| ta_der_strict 𝒜 t"
    by auto
next
  show "ta_der_strict 𝒜 t |⊆| ta_der 𝒜 t" using ta_der_strict_sub_ta_der .
qed

lemma ta_der_to_ta_strict:
  assumes "q |∈| ta_der A C⟨Var p⟩" and "ground_ctxt C"
  shows "∃ q'. (p = q' ∨ (p, q') |∈| (eps A)|+|) ∧ q |∈| ta_der_strict A C⟨Var q'⟩"
  using assms
proof (induct C arbitrary: q p)
  case (More f ss C ts)
  from More(2) obtain qs q' where
    r: "TA_rule f qs q' |∈| rules A" "length qs = Suc (length ss + length ts)" "q' = q ∨ (q', q) |∈| (eps A)|+|" and
    rec: "∀ i < length qs. qs ! i |∈| ta_der A ((ss @ C⟨Var p⟩ # ts) ! i)"
    by auto
  from More(1)[of "qs ! length ss" p] More(3) rec r(2) obtain q'' where
    mid: "(p = q'' ∨ (p, q'') |∈| (eps A)|+|) ∧ qs ! length ss |∈| ta_der_strict A C⟨Var q''⟩"
    by auto (metis length_map less_add_Suc1 nth_append_length)
  then have "∀ i < length qs. qs ! i |∈| ta_der_strict A ((ss @ C⟨Var q''⟩ # ts) ! i)"
    using rec r(2) More(3)
    using ta_der_strict_ta_der_eq_on_ground[of _ A]
    by (auto simp: nth_append_Cons all_Suc_conv fmember.rep_eq split:if_splits cong: if_cong')
  then show ?case using rec r conjunct1[OF mid]
    by (rule_tac x = q'' in exI, auto intro!: exI[of _ q'] exI[of _ qs])
qed auto

fun root_ctxt where
  "root_ctxt (More f ss C ts) = f"
| "root_ctxt □ = undefined"

lemma root_to_root_ctxt [simp]:
  assumes "C ≠ □"
  shows "fst (the (root C⟨t⟩)) ⟷ root_ctxt C"
  using assms by (cases C) auto


(* Q_inf section *)

inductive_set Q_inf for 𝒜 where
  trans: "(p, q) ∈ Q_inf 𝒜 ⟹ (q, r) ∈ Q_inf 𝒜 ⟹ (p, r) ∈ Q_inf 𝒜"
| rule: "(None, Some f) qs → q |∈| rules 𝒜 ⟹ i < length qs ⟹ (qs ! i, q) ∈ Q_inf 𝒜"
| eps: "(p, q) ∈ Q_inf 𝒜 ⟹ (q, r) |∈| eps 𝒜 ⟹ (p, r) ∈ Q_inf 𝒜"

abbreviation "Q_inf_e 𝒜 ≡ {q | p q. (p, p) ∈ Q_inf 𝒜 ∧ (p, q) ∈ Q_inf 𝒜}"

lemma Q_inf_states_ta_states:
  assumes "(p, q) ∈ Q_inf 𝒜"
  shows "p |∈| 𝒬 𝒜" "q |∈| 𝒬 𝒜"
  using assms by (induct) (auto simp: rule_statesD eps_statesD)

lemma Q_inf_finite:
  "finite (Q_inf 𝒜)" "finite (Q_inf_e 𝒜)"
proof -
  have *: "Q_inf 𝒜 ⊆ fset (𝒬 𝒜 |×| 𝒬 𝒜)" "Q_inf_e 𝒜 ⊆ fset (𝒬 𝒜)"
    by (auto simp add: Q_inf_states_ta_states(1, 2) subrelI simp flip: fmember.rep_eq)
  show "finite (Q_inf 𝒜)"
    by (intro finite_subset[OF *(1)]) simp
  show "finite (Q_inf_e 𝒜)"
    by (intro finite_subset[OF *(2)]) simp
qed

context
includes fset.lifting
begin
lift_definition fQ_inf :: "('a, 'b option × 'c option) ta ⇒ ('a × 'a) fset" is Q_inf
  by (simp add: Q_inf_finite(1))
lift_definition fQ_inf_e :: "('a, 'b option × 'c option) ta ⇒ 'a fset" is Q_inf_e
  using Q_inf_finite(2) .
end


lemma Q_inf_ta_eps_Q_inf:
  assumes "(p, q) ∈ Q_inf 𝒜" and "(q, q') |∈| (eps 𝒜)|+|"
  shows "(p, q') ∈ Q_inf 𝒜" using assms(2, 1)
  by (induct rule: ftrancl_induct) (auto simp add: Q_inf.eps)

lemma lhs_state_rule:
  assumes "(p, q) ∈ Q_inf 𝒜"
  shows "∃ f qs r. (None, Some f) qs → r |∈| rules 𝒜 ∧ p |∈| fset_of_list qs"
  using assms by induct (force intro: nth_mem)+

lemma Q_inf_reach_state_rule:
  assumes "(p, q) ∈ Q_inf 𝒜" and "𝒬 𝒜 |⊆| ta_reachable 𝒜"
  shows "∃ ss ts f C. q |∈| ta_der 𝒜 (More (None, Some f) ss C ts)⟨Var p⟩ ∧ ground_ctxt (More (None, Some f) ss C ts)"
    (is "∃ ss ts f C. ?P ss ts f C q p")
  using assms
proof (induct)
  case (trans p q r)
  then obtain f1 f2 ss1 ts1 ss2 ts2 C1 C2 where
    C: "?P ss1 ts1 f1 C1 q p" "?P ss2 ts2 f2 C2 r q" by blast
  then show ?case
    apply (rule_tac x = "ss2" in exI, rule_tac x = "ts2" in exI, rule_tac x = "f2" in exI,
        rule_tac x = "C2 ∘c (More (None, Some f1) ss1 C1 ts1)" in exI)
    apply (auto simp del: ctxt_apply_term.simps)
    apply (metis Subterm_and_Context.ctxt_ctxt_compose ctxt_compose.simps(2) ta_der_ctxt)
    done
next
  case (rule f qs q i)
  have "∀ i < length qs. ∃ t. qs ! i |∈| ta_der 𝒜 t ∧ ground t"
    using rule(1, 2) fset_mp[OF rule(3), of "qs ! i" for i]
    by auto (meson fnth_mem rule_statesD(4) ta_reachableE) 
  then obtain ts where wit: "length ts = length qs"
    "∀ i < length qs. qs ! i |∈| ta_der 𝒜 (ts ! i) ∧ ground (ts ! i)"
    using Ex_list_of_length_P[of "length qs" "λ x i. qs ! i |∈| ta_der 𝒜 x ∧ ground x"] by blast
  {fix j assume "j < length qs"
    then have "qs ! j |∈| ta_der 𝒜 ((take i ts @ Var (qs ! i) # drop (Suc i) ts) ! j)"
      using wit by (cases "j < i") (auto simp: min_def nth_append_Cons)}
  then have "∀ i < length qs. qs ! i |∈| (map (ta_der 𝒜) (take i ts @ Var (qs ! i) # drop (Suc i) ts)) ! i"
    using wit rule(2) by (auto simp: nth_append_Cons)
  then have res: "q |∈| ta_der 𝒜 (Fun (None, Some f) (take i ts @ Var (qs ! i) # drop (Suc i) ts))"
    using rule(1, 2) wit by (auto simp: min_def nth_append_Cons intro!: exI[of _ q] exI[of _ qs])
  then show ?case using rule(1, 2) wit
    apply (rule_tac x = "take i ts" in exI, rule_tac x = "drop (Suc i) ts" in exI)
    apply (auto simp: take_map drop_map  dest!: in_set_takeD in_set_dropD simp del: ta_der_simps intro!: exI[of _ f] exI[of _ Hole])
    apply (metis all_nth_imp_all_set)+
    done
next
  case (eps p q r)
  then show ?case by (meson r_into_rtrancl ta_der_eps)
qed

lemma rule_target_Q_inf:
  assumes "(None, Some f) qs → q' |∈| rules 𝒜" and "i < length qs"
   shows "(qs ! i, q') ∈ Q_inf 𝒜" using assms  
  by (intro rule) auto

lemma rule_target_eps_Q_inf:
  assumes "(None, Some f) qs → q' |∈| rules 𝒜" "(q', q) |∈| (eps 𝒜)|+|"
     and "i < length qs"
   shows "(qs ! i, q) ∈ Q_inf 𝒜"
  using assms(2, 1, 3) by (induct rule: ftrancl_induct) (auto intro: rule eps)


lemma step_in_Q_inf:
  assumes "q |∈| ta_der_strict 𝒜 (map_funs_term (λf. (None, Some f)) (Fun f (ss @ Var p # ts)))"
    shows "(p, q) ∈ Q_inf 𝒜"
  using assms rule_target_eps_Q_inf[of f _ _ 𝒜 q] rule_target_Q_inf[of f _ q 𝒜]
  by (auto simp: comp_def nth_append_Cons split!: if_splits) 


lemma ta_der_Q_inf:
  assumes "q |∈| ta_der_strict 𝒜 (map_funs_term (λf. (None, Some f)) (C⟨Var p⟩))" and "C ≠ Hole"
  shows "(p, q) ∈ Q_inf 𝒜" using assms
proof (induct C arbitrary: q)
  case (More f ss C ts)
  then show ?case
  proof (cases "C = Hole")
    case True
    then show ?thesis using More(2) by (auto simp: step_in_Q_inf)
  next
    case False
    then obtain q' where q: "q' |∈| ta_der_strict 𝒜 (map_funs_term (λf. (None, Some f)) C⟨Var p⟩)"
     "q |∈| ta_der_strict 𝒜 (map_funs_term (λf. (None, Some f)) (Fun f (ss @ Var q' # ts)))"
      using More(2) length_map
     (* SLOW *)
      by (auto simp: comp_def nth_append_Cons split: if_splits cong: if_cong')
         (smt nat_neq_iff nth_map ta_der_strict_simps)+
    have "(p, q') ∈ Q_inf 𝒜" using More(1)[OF q(1) False] .
    then show ?thesis using step_in_Q_inf[OF q(2)] by (auto intro: trans)
  qed
qed auto

lemma Q_inf_e_infinite_terms_res:
  assumes "q ∈ Q_inf_e 𝒜" and "𝒬 𝒜 |⊆| ta_reachable 𝒜"
  shows "infinite {t. q |∈| ta_der 𝒜 (term_of_gterm t) ∧ fst (groot_sym t) = None}"
proof -
  let ?P ="λ u. ground u ∧ q |∈| ta_der 𝒜 u ∧ fst (fst (the (root u))) = None"
  have groot[simp]: "fst (fst (the (root (term_of_gterm t)))) = fst (groot_sym t)" for t by (cases t) auto
  have [simp]: "C ≠ □ ⟹ fst (fst (the (root C⟨t⟩))) = fst (root_ctxt C)" for C t by (cases C) auto
  from assms(1) obtain p where cycle: "(p, p) ∈ Q_inf 𝒜" "(p, q) ∈ Q_inf 𝒜" by auto
  from Q_inf_reach_state_rule[OF cycle(1) assms(2)] obtain C where
    ctxt: "C ≠ □" "ground_ctxt C" and reach: "p |∈| ta_der 𝒜 C⟨Var p⟩"
    by blast
  obtain C2 where
    closing_ctxt: "C2 ≠ □" "ground_ctxt C2" "fst (root_ctxt C2) = None" and cl_reach: "q |∈| ta_der 𝒜 C2⟨Var p⟩"
    by (metis (full_types) Q_inf_reach_state_rule[OF cycle(2) assms(2)] ctxt.distinct(1) fst_conv root_ctxt.simps(1))
  from assms(2) obtain t where t: "p |∈| ta_der 𝒜 t" and gr_t: "ground t"
    by (meson Q_inf_states_ta_states(1) cycle(1) fsubsetD ta_reachableE)
  let ?terms = "λ n. (C ^ Suc n)⟨t⟩" let ?S = "{?terms n | n. p |∈| ta_der 𝒜 (?terms n) ∧ ground (?terms n)}"
  have "ground (?terms n)" for n using ctxt(2) gr_t by auto
  moreover have "p |∈| ta_der 𝒜 (?terms n)" for n using reach t(1)
    by (auto simp: ta_der_ctxt) (meson ta_der_ctxt ta_der_ctxt_n_loop)
  ultimately have inf: "infinite ?S" using ctxt_comp_n_lower_bound[OF ctxt(1)]
    using no_upper_bound_infinite[of _ depth, of ?S] by blast
  from infinite_inj_image_infinite[OF this] have inf:"infinite (ctxt_apply_term C2 ` ?S)"
    by (smt ctxt_eq inj_on_def)
  {fix u assume "u ∈ (ctxt_apply_term C2 ` ?S)"
    then have "?P u" unfolding image_Collect using closing_ctxt cl_reach
      by (auto simp: ta_der_ctxt)}
  from this have inf: "infinite {u. ground u ∧ q |∈| ta_der 𝒜 u ∧ fst (fst (the (root u))) = None}"
    by (intro infinite_super[OF _ inf] subsetI) fast
  have inf: "infinite (gterm_of_term ` {u. ground u ∧ q |∈| ta_der 𝒜 u ∧ fst (fst (the (root u))) = None})"
    by (intro infinite_inj_image_infinite[OF inf] gterm_of_term_inj) auto
  show ?thesis
    by (intro infinite_super[OF _ inf]) (auto dest: groot_sym_gterm_of_term)
qed













lemma gfun_at_after_hole_pos:
  assumes "ghole_pos C ≤p p"
  shows "gfun_at C⟨t⟩G p = gfun_at t (p -p ghole_pos C)" using assms
proof (induct C arbitrary: p)
  case (GMore f ss C ts) then show ?case
    by (cases p) auto
qed auto

lemma pos_diff_0 [simp]: "p -p p = []"
  by (auto simp: pos_diff_def)

lemma Max_suffI: "finite A ⟹ A = B ⟹ Max A = Max B"
  by (intro Max_eq_if) auto

lemma nth_args_depth_eqI:
  assumes "length ss = length ts"
    and "⋀ i. i < length ts ⟹ depth (ss ! i) = depth (ts ! i)"
  shows "depth (Fun f ss) = depth (Fun g ts)"
proof -
  from assms(1, 2) have "depth ` set ss = depth ` set ts"
    using nth_map_conv[OF assms(1), of depth depth]
    by (simp flip: set_map)
  from Max_suffI[OF _ this] show ?thesis using assms(1)
    by (cases ss; cases ts) auto
qed

lemma subt_at_ctxt_apply_hole_pos [simp]: "C⟨s⟩ |_ hole_pos C = s"
  by (induct C) auto

lemma ctxt_at_pos_ctxt_apply_hole_poss [simp]: "ctxt_at_pos C⟨s⟩ (hole_pos C) = C"
  by (induct C) auto

abbreviation "map_funs_ctxt f ≡ map_ctxt f (λ x. x)"
lemma map_funs_term_ctxt_apply [simp]:
  "map_funs_term f C⟨s⟩ = (map_funs_ctxt f C)⟨map_funs_term f s⟩"
  by (induct C) auto

lemma map_funs_term_ctxt_decomp:
  assumes "map_funs_term fg t = C⟨s⟩"
  shows "∃ D u. C = map_funs_ctxt fg D ∧ s = map_funs_term fg u ∧ t = D⟨u⟩"
using assms
proof (induct C arbitrary: t)
  case Hole
  show ?case
    by (rule exI[of _ Hole], rule exI[of _ t], insert Hole, auto)
next
  case (More g bef C aft)
  from More(2) obtain f ts where t: "t = Fun f ts" by (cases t, auto)
  from More(2)[unfolded t] have f: "fg f = g" and ts: "map (map_funs_term fg) ts = bef @ C⟨s⟩ # aft" (is "?ts = ?bca") by auto
  from ts have "length ?ts = length ?bca" by auto
  then have len: "length ts = length ?bca" by auto
  note id = ts[unfolded map_nth_eq_conv[OF len], THEN spec, THEN mp]
  let ?i = "length bef"
  from len have i: "?i < length ts" by auto
  from id[of ?i] have "map_funs_term fg (ts ! ?i) = C⟨s⟩" by auto
  from More(1)[OF this] obtain D u where D: "C = map_funs_ctxt fg D" and
    u: "s = map_funs_term fg u" and id: "ts ! ?i = D⟨u⟩" by auto
  from ts have "take ?i ?ts = take ?i ?bca" by simp
  also have "... = bef" by simp
  finally have bef: "map (map_funs_term fg) (take ?i ts) = bef" by (simp add: take_map)
  from ts have "drop (Suc ?i) ?ts = drop (Suc ?i) ?bca" by simp
  also have "... = aft" by simp
  finally have aft: "map (map_funs_term fg) (drop (Suc ?i) ts) = aft" by (simp add:drop_map)
  let ?bda = "take ?i ts @ D⟨u⟩ # drop (Suc ?i) ts"
  show ?case
  proof (rule exI[of _ "More f (take ?i ts) D (drop (Suc ?i) ts)"],
      rule exI[of _ u], simp add: u f D bef aft t)
    have "ts = take ?i ts @ ts ! ?i # drop (Suc ?i) ts"
      by (rule id_take_nth_drop[OF i])
    also have "... = ?bda" by (simp add: id)
    finally show "ts = ?bda" .
  qed
qed





lemma prod_automata_from_none_root_dec:
  assumes "gta_lang Q 𝒜 ⊆ {gpair s t| s t. funas_gterm s ⊆ ℱ ∧ funas_gterm t ⊆ ℱ}"
    and "q |∈| ta_der 𝒜 (term_of_gterm t)" and "fst (groot_sym t) = None"
    and "𝒬 𝒜 |⊆| ta_reachable 𝒜" and "q |∈| ta_productive Q 𝒜"
  shows "∃ u. t = gterm_to_None_Some u ∧ funas_gterm u ⊆ ℱ"
proof -
  have *: "gfun_at t [] = Some (groot_sym t)" by (cases t) auto
  from assms(4, 5) obtain C qf where ctxt: "ground_ctxt C" and
    fin: "qf |∈| ta_der 𝒜 C⟨Var q⟩" "qf |∈| Q"
    by (auto simp: ta_productive_def'[OF assms(4)])
  then obtain s v where gp: "gpair s v = (gctxt_of_ctxt C)⟨t⟩G" and
   funas: "funas_gterm v ⊆ ℱ"
    using assms(1, 2) gta_langI[OF fin(2), of 𝒜 "(gctxt_of_ctxt C)⟨t⟩G"]
    by (auto simp: ta_der_ctxt ground_gctxt_of_ctxt_apply_gterm)
  from gp have mem: "hole_pos C ∈ gposs s ∪ gposs v"
    by auto (metis Un_iff ctxt ghole_pos_in_apply gposs_of_gpair ground_hole_pos_to_ghole)
  from this have "hole_pos C ∉ gposs s" using assms(3)
    using arg_cong[OF gp, of "λ t. gfun_at t (hole_pos C)"]
    using ground_hole_pos_to_ghole[OF ctxt]
    using gfun_at_after_hole_pos[OF position_less_refl, of "gctxt_of_ctxt C"]
    by (auto simp: gfun_at_gpair * split: if_splits)
       (metis fstI gfun_at_None_ngposs_iff)+
  from subst_at_gpair_nt_poss_None_Some[OF _ this, of v] this
  have "t = gterm_to_None_Some (gsubt_at v (hole_pos C)) ∧ funas_gterm (gsubt_at v (hole_pos C)) ⊆ ℱ"
    using funas mem funas_gterm_gsubt_at_subseteq
    by (auto simp: gp intro!: exI[of _ "gsubt_at v (hole_pos C)"])
       (metis ctxt ground_hole_pos_to_ghole gsubt_at_gctxt_apply_ghole)
  then show ?thesis by blast
qed

lemma infinite_set_dec_infinite:
  assumes "infinite S" and "⋀ s. s ∈ S ⟹ ∃ t. f t = s ∧ P t"
  shows "infinite {t | t s. s ∈ S ∧ f t = s ∧ P t}" (is "infinite ?T")
proof (rule ccontr)
  assume ass: "¬ infinite ?T"
  have "S ⊆ f ` {x . P x}" using assms(2) by auto 
  then show False using ass assms(1)
    by (auto simp: subset_image_iff)
      (smt Ball_Collect finite_imageI image_subset_iff infinite_iff_countable_subset subset_eq) 
qed

lemma Q_inf_exec_impl_Q_inf:
  assumes "gta_lang Q 𝒜 ⊆ {gpair s t| s t. funas_gterm s ⊆ fset ℱ ∧ funas_gterm t ⊆ fset ℱ}"
   and "𝒬 𝒜 |⊆| ta_reachable 𝒜" and "𝒬 𝒜 |⊆| ta_productive Q 𝒜"
   and "q ∈ Q_inf_e 𝒜"
  shows "q |∈| Q_infty 𝒜 ℱ"
proof -
  let ?S = "{t. q |∈| ta_der 𝒜 (term_of_gterm t) ∧ fst (groot_sym t) = None}"
  let ?P = "λ t. funas_gterm t ⊆ fset ℱ ∧ q |∈| ta_der 𝒜 (term_of_gterm (gterm_to_None_Some t))"
  let ?F = "(λ(f, n). ((None, Some f), n)) |`| ℱ"
  from Q_inf_e_infinite_terms_res[OF assms(4, 2)] have inf: "infinite ?S" by auto
  {fix t assume "t ∈ ?S"
    then have "∃ u. t = gterm_to_None_Some u ∧ funas_gterm u ⊆ fset ℱ"
      using prod_automata_from_none_root_dec[OF assms(1)] assms(2, 3)
      using fin_mono by fastforce}
  then show ?thesis using infinite_set_dec_infinite[OF inf, of gterm_to_None_Some ?P]
    by (auto simp: Q_infty_fmember) blast
qed


lemma Q_inf_impl_Q_inf_exec:
  assumes "q |∈| Q_infty 𝒜 ℱ"
    shows "q ∈ Q_inf_e 𝒜"
proof -
  let ?t_of_g = "λ t. term_of_gterm t :: ('b option × 'b option, 'a) term"
  let ?t_og_g2 = "λ t. term_of_gterm t :: ('b, 'a) term"
  let ?inf = "(?t_og_g2 :: 'b gterm ⇒ ('b, 'a) term) ` {t |t. funas_gterm t ⊆ fset ℱ ∧ q |∈| ta_der 𝒜 (?t_of_g (gterm_to_None_Some t))}"
  obtain n where card_st: "fcard (𝒬 𝒜) < n" by blast
  from assms(1) have "infinite {t |t. funas_gterm t ⊆ fset ℱ ∧ q |∈| ta_der 𝒜 (?t_of_g (gterm_to_None_Some t))}"
    unfolding Q_infty_def by blast
  from infinite_inj_image_infinite[OF this, of "?t_og_g2"] have inf: "infinite ?inf" using inj_term_of_gterm by blast
  {fix s assume "s ∈ ?inf" then have "ground s" "funas_term s ⊆ fset ℱ" by (auto simp: funas_term_of_gterm_conv subsetD)}
  from infinte_no_depth_limit[OF inf, of "fset ℱ"] this obtain u where
    funas: "funas_gterm u ⊆ fset ℱ" and card_d: "n < depth (?t_og_g2 u)" and reach: "q |∈| ta_der 𝒜 (?t_of_g (gterm_to_None_Some u))"
    by auto blast
  have "depth (?t_og_g2 u) = depth (?t_of_g (gterm_to_None_Some u))"
  proof (induct u)
    case (GFun f ts) then show ?case
      by (auto simp: comp_def intro: nth_args_depth_eqI)
  qed 
  from this pigeonhole_tree_automata[OF _ reach] card_st card_d obtain C2 C s v p where
    ctxt: "C2 ≠ □" "C⟨s⟩ = term_of_gterm (gterm_to_None_Some u)" "C2⟨v⟩ = s" and
    loop: "p |∈| ta_der 𝒜 v ∧ p |∈| ta_der 𝒜 C2⟨Var p⟩ ∧ q |∈| ta_der 𝒜 C⟨Var p⟩"
    by auto
  from ctxt have gr: "ground_ctxt C2" "ground_ctxt C" by auto (metis ground_ctxt_apply ground_term_of_gterm)+ 
  from ta_der_to_ta_strict[OF _ gr(1)] loop obtain q' where
    to_strict: "(p = q' ∨ (p, q') |∈| (eps 𝒜)|+|) ∧ p |∈| ta_der_strict 𝒜 C2⟨Var q'⟩" by fastforce
  have *: "∃ C. C2 = map_funs_ctxt lift_None_Some C ∧ C ≠ □" using ctxt(1, 2)
    by (auto simp flip: ctxt(3)) (smt ctxt.simps(8) map_funs_term_ctxt_decomp map_term_of_gterm)
  then have q_p: "(q', p) ∈ Q_inf 𝒜" using to_strict ta_der_Q_inf[of p 𝒜 _  q'] ctxt
    by auto
  then have cycle: "(q', q') ∈ Q_inf 𝒜" using to_strict by (auto intro: Q_inf_ta_eps_Q_inf)
  show ?thesis
  proof (cases "C = □")
    case True then show ?thesis
      using cycle q_p loop by (auto intro: Q_inf_ta_eps_Q_inf)
  next
    case False
    obtain q'' where r: "p = q'' ∨ (p, q'') |∈| (eps 𝒜)|+|" "q |∈| ta_der_strict 𝒜 C⟨Var q''⟩"
      using ta_der_to_ta_strict[OF conjunct2[OF conjunct2[OF loop]] gr(2)] by auto
    then have "(q'', q) ∈  Q_inf 𝒜" using ta_der_Q_inf[of q 𝒜 _  q''] ctxt False
      by auto (smt (z3) ctxt.simps(8) map_funs_term_ctxt_decomp map_term_of_gterm)+
    then show ?thesis using r(1) cycle q_p
      by (auto simp: Q_inf_ta_eps_Q_inf intro!: exI[of _ q'])
         (meson Q_inf.trans Q_inf_ta_eps_Q_inf)+   
  qed
qed

lemma Q_infty_fQ_inf_e_conv:
  assumes "gta_lang Q 𝒜 ⊆ {gpair s t| s t. funas_gterm s ⊆ fset ℱ ∧ funas_gterm t ⊆ fset ℱ}"
   and "𝒬 𝒜 |⊆| ta_reachable 𝒜" and "𝒬 𝒜 |⊆| ta_productive Q 𝒜"
  shows "Q_infty 𝒜 ℱ = fQ_inf_e 𝒜"
  using Q_inf_impl_Q_inf_exec Q_inf_exec_impl_Q_inf[OF assms]
  by (auto simp: fQ_inf_e.rep_eq fmember.rep_eq) fastforce

definition Inf_reg_impl where
  "Inf_reg_impl R = Inf_reg R (fQ_inf_e (ta R))"

lemma Inf_reg_impl_sound:
  assumes "ℒ 𝒜 ⊆ {gpair s t| s t. funas_gterm s ⊆ fset ℱ ∧ funas_gterm t ⊆ fset ℱ}"
   and "𝒬r 𝒜 |⊆| ta_reachable (ta 𝒜)" and "𝒬r 𝒜 |⊆| ta_productive (fin 𝒜) (ta 𝒜)"
  shows "ℒ (Inf_reg_impl 𝒜) = ℒ (Inf_reg 𝒜 (Q_infty (ta 𝒜) ℱ))"
  using Q_infty_fQ_inf_e_conv[of "fin 𝒜" "ta 𝒜" ℱ] assms[unfolded ℒ_def]
  by (simp add: Inf_reg_impl_def)

end
tle>

Theory Regular_Relation_Abstract_Impl

theory Regular_Relation_Abstract_Impl
  imports Pair_Automaton
    GTT_Transitive_Closure
    RR2_Infinite_Q_infinity
    Horn_Fset
begin

abbreviation TA_of_lists where
  "TA_of_lists Δ ΔE ≡ TA (fset_of_list Δ) (fset_of_list ΔE)"

section ‹Computing the epsilon transitions for the composition of GTT's›

definition Δε_rules :: "('q, 'f) ta ⇒ ('q, 'f) ta ⇒ ('q × 'q) horn set" where
  "Δε_rules A B =
    {zip ps qs →h (p, q) |f ps p qs q. f ps → p |∈| rules A ∧ f qs → q |∈| rules B ∧ length ps = length qs} ∪
    {[(p, q)] →h (p', q) |p p' q. (p, p') |∈| eps A} ∪
    {[(p, q)] →h (p, q') |p q q'. (q, q') |∈| eps B}"

locale Δε_horn =
  fixes A :: "('q, 'f) ta" and B :: "('q, 'f) ta"
begin

sublocale horn "Δε_rules A B" .

lemma Δε_infer0:
  "infer0 = {(p, q) |f p q. f [] → p |∈| rules A ∧ f [] → q |∈| rules B}"
  unfolding horn.infer0_def Δε_rules_def
  using zip_Nil[of "[]"]
  by auto (metis length_greater_0_conv zip_eq_Nil_iff)+

lemma Δε_infer1:
  "infer1 pq X = {(p, q) |f ps p qs q. f ps → p |∈| rules A ∧ f qs → q |∈| rules B ∧ length ps = length qs ∧
    (fst pq, snd pq) ∈ set (zip ps qs) ∧ set (zip ps qs) ⊆ insert pq X} ∪
    {(p', snd pq) |p p'. (p, p') |∈| eps A ∧ p = fst pq} ∪
    {(fst pq, q') |q q'. (q, q') |∈| eps B ∧ q = snd pq}"
  unfolding Δε_rules_def horn_infer1_union
  apply (intro arg_cong2[of _ _ _ _ "(∪)"])
    by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+

lemma Δε_sound:
  "Δε_set A B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using lr unfolding x
  proof (induct)
    case (Δε_set_cong f ps p qs q) show ?case
      apply (intro infer[of "zip ps qs" "(p, q)"])
      subgoal using Δε_set_cong(1-3) by (auto simp: Δε_rules_def)
      subgoal using Δε_set_cong(3,5) by (auto simp: zip_nth_conv)
      done
  next
    case (Δε_set_eps1 p p' q) then show ?case
      by (intro infer[of "[(p, q)]" "(p', q)"]) (auto simp: Δε_rules_def)
  next
    case (Δε_set_eps2 q q' p) then show ?case
      by (intro infer[of "[(p, q)]" "(p, q')"]) (auto simp: Δε_rules_def)
  qed
next
  case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using rl unfolding x
  proof (induct)
    case (infer as a) then show ?case
      using Δε_set_cong[of _ "map fst as" "fst a" A "map snd as" "snd a" B]
        Δε_set_eps1[of _ "fst a" A "snd a" B] Δε_set_eps2[of _ "snd a" B "fst a" A]
      by (auto simp: Δε_rules_def)
  qed
qed

end

section ‹Computing the epsilon transitions for the transitive closure of GTT's›

definition Δ_trancl_rules :: "('q, 'f) ta ⇒ ('q, 'f) ta ⇒ ('q × 'q) horn set" where
  "Δ_trancl_rules A B =
    Δε_rules A B ∪ {[(p, q), (q, r)] →h (p, r) |p q r. True}"

locale Δ_trancl_horn =
  fixes A :: "('q, 'f) ta" and B :: "('q, 'f) ta"
begin

sublocale horn "Δ_trancl_rules A B" .

lemma Δ_trancl_infer0:
  "infer0 = horn.infer0 (Δε_rules A B)"
  by (auto simp: Δε_rules_def Δ_trancl_rules_def horn.infer0_def)

lemma Δ_trancl_infer1:
  "infer1 pq X = horn.infer1 (Δε_rules A B) pq X ∪
   {(r, snd pq) |r p'. (r, p') ∈ X ∧ p' = fst pq} ∪
   {(fst pq, r) |q' r. (q', r) ∈ (insert pq X) ∧ q' = snd pq}"
  unfolding Δ_trancl_rules_def horn_infer1_union Un_assoc
  apply (intro arg_cong2[of _ _ _ _ "(∪)"] HOL.refl)
  by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+

lemma Δ_trancl_sound:
  "Δ_trancl_set A B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using lr unfolding x
  proof (induct)
    case (Δ_set_cong f ps p qs q) show ?case
      apply (intro infer[of "zip ps qs" "(p, q)"])
      subgoal using Δ_set_cong(1-3) by (auto simp: Δ_trancl_rules_def Δε_rules_def)
      subgoal using Δ_set_cong(3,5) by (auto simp: zip_nth_conv)
      done
  next
    case (Δ_set_eps1 p p' q) then show ?case
      by (intro infer[of "[(p, q)]" "(p', q)"]) (auto simp: Δ_trancl_rules_def Δε_rules_def)
  next
    case (Δ_set_eps2 q q' p) then show ?case
      by (intro infer[of "[(p, q)]" "(p, q')"]) (auto simp: Δ_trancl_rules_def Δε_rules_def)
  next
    case (Δ_set_trans p q r) then show ?case
      by (intro infer[of "[(p,q), (q,r)]" "(p, r)"]) (auto simp: Δ_trancl_rules_def Δε_rules_def)
  qed
next
  case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using rl unfolding x
  proof (induct)
    case (infer as a) then show ?case
      using Δ_set_cong[of _ "map fst as" "fst a" A "map snd as" "snd a" B]
        Δ_set_eps1[of _ "fst a" A "snd a" B] Δ_set_eps2[of _ "snd a" B "fst a" A]
        Δ_set_trans[of "fst a" "snd (hd as)" A B "snd a"]
      by (auto simp: Δ_trancl_rules_def Δε_rules_def)
  qed
qed

end

section ‹Computing the epsilon transitions for the transitive closure of pair automata›

definition Δ_Atr_rules :: "('q × 'q) fset ⇒ ('q, 'f) ta ⇒ ('q, 'f) ta ⇒ ('q × 'q) horn set" where
  "Δ_Atr_rules Q A B =
    {[] →h (p, q) | p q. (p , q) |∈| Q} ∪
    {[(p, q),(r, v)] →h (p, v) |p q r v. (q, r) |∈| Δε B A}"

locale Δ_Atr_horn =
  fixes Q :: "('q × 'q) fset" and A :: "('q, 'f) ta" and B :: "('q, 'f) ta"
begin

sublocale horn "Δ_Atr_rules Q A B" .

lemma Δ_Atr_infer0: "infer0 = fset Q"
  by (auto simp: horn.infer0_def Δ_Atr_rules_def fmember.rep_eq)
  
lemma Δ_Atr_infer1:
  "infer1 pq X = {(p, snd pq) | p q. (p, q) ∈ X ∧ (q, fst pq) |∈| Δε B A} ∪
   {(fst pq, v) | q r v. (snd pq, r) |∈| Δε B A ∧ (r, v) ∈ X} ∪
   {(fst pq, snd pq) | q . (snd pq, fst pq) |∈| Δε B A}"
  unfolding Δ_Atr_rules_def horn_infer1_union
  by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+

lemma Δ_Atr_sound:
  "Δ_Atrans_set Q A B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using lr unfolding x
  proof (induct)
    case (base p q)
    then show ?case
      by (intro infer[of "[]" "(p, q)"]) (auto simp: Δ_Atr_rules_def)
  next
    case (step p q r v)
    then show ?case
      by (intro infer[of "[(p, q), (r, v)]" "(p, v)"]) (auto simp: Δ_Atr_rules_def)
  qed
next
  case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using rl unfolding x
  proof (induct)
    case (infer as a) then show ?case
      using base[of "fst a" "snd a" Q A B]
      using Δ_Atrans_set.step[of "fst a" _ Q A B "snd a"]
      by (auto simp: Δ_Atr_rules_def) blast
  qed
qed

end

section ‹Computing the Q infinity set for the infinity predicate automaton›

definition Q_inf_rules :: "('q, 'f option × 'g option) ta ⇒ ('q × 'q) horn set" where
  "Q_inf_rules A =
    {[] →h (ps ! i, p) |f ps p i. (None, Some f) ps → p |∈| rules A ∧ i < length ps} ∪
    {[(p, q)] →h (p, r) |p q r. (q, r) |∈| eps A} ∪
    {[(p, q), (q, r)] →h (p, r) |p q r. True}"

locale Q_horn =
  fixes A :: "('q, 'f option × 'g option) ta"
begin

sublocale horn "Q_inf_rules A" .

lemma Q_infer0:
  "infer0 = {(ps ! i, p) |f ps p i. (None, Some f) ps → p |∈| rules A ∧ i < length ps}"
  unfolding horn.infer0_def Q_inf_rules_def by auto

lemma Q_infer1:
  "infer1 pq X = {(fst pq, r) | q r. (q, r) |∈| eps A ∧ q = snd pq} ∪
    {(r, snd pq) |r p'. (r, p') ∈ X ∧ p' = fst pq} ∪
    {(fst pq, r) |q' r. (q', r) ∈ (insert pq X) ∧ q' = snd pq}"
  unfolding Q_inf_rules_def horn_infer1_union
  by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+

lemma Q_sound:
  "Q_inf A = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using lr unfolding x
  proof (induct)
    case (trans p q r)
    then show ?case
      by (intro infer[of "[(p,q), (q,r)]" "(p, r)"])
        (auto simp: Q_inf_rules_def)
  next
    case (rule f qs q i)
    then show ?case
      by (intro infer[of "[]" "(qs ! i, q)"])
        (auto simp: Q_inf_rules_def)
  next
    case (eps p q r)
    then show ?case
      by (intro infer[of "[(p, q)]" "(p, r)"])
        (auto simp: Q_inf_rules_def)
  qed
next
  case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using rl unfolding x
  proof (induct)
    case (infer as a) then show ?case
      using Q_inf.eps[of "fst a" _ A "snd a"]
      using Q_inf.trans[of "fst a" "snd (hd as)" A "snd a"]
      by (auto simp: Q_inf_rules_def intro: Q_inf.rule)
  qed
qed

end


end
ad>

Theory Regular_Relation_Impl

theory Regular_Relation_Impl
  imports Tree_Automata_Impl
    Regular_Relation_Abstract_Impl
    Horn_Fset
begin

section ‹Computing the epsilon transitions for the composition of GTT's›

definition Δε_infer0_cont where
  "Δε_infer0_cont ΔA ΔB =
    (let arules = filter (λ r. r_lhs_states r = []) (sorted_list_of_fset ΔA) in
     let brules = filter (λ r. r_lhs_states r = []) (sorted_list_of_fset ΔB) in
    (map (map_prod r_rhs r_rhs) (filter (λ(ra, rb). r_root ra = r_root rb) (List.product arules brules))))"

definition Δε_infer1_cont where
  "Δε_infer1_cont ΔA ΔAε ΔB ΔBε =
   (let (arules, aeps) = (sorted_list_of_fset ΔA, sorted_list_of_fset ΔAε) in
    let (brules, beps) = (sorted_list_of_fset ΔB, sorted_list_of_fset ΔBε) in
    let prules = List.product arules brules in
   (λ pq bs.
      map (map_prod r_rhs r_rhs) (filter (λ(ra, rb). case (ra, rb) of (TA_rule f ps p, TA_rule g qs q) ⇒
        f = g ∧ length ps = length qs ∧ (fst pq, snd pq) ∈ set (zip ps qs) ∧
        set (zip ps qs) ⊆ insert (fst pq, snd pq) (fset bs)) prules) @
      map (λ(p, p'). (p', snd pq)) (filter (λ(p, p') ⇒ p = fst pq) aeps) @
      map (λ(q, q'). (fst pq, q')) (filter (λ(q, q') ⇒ q = snd pq) beps)))"


locale Δε_fset =
  fixes ΔA :: "('q :: linorder, 'f :: linorder) ta_rule fset" and ΔAε :: "('q × 'q) fset"
    and ΔB :: "('q, 'f) ta_rule fset" and ΔBε :: "('q × 'q) fset"
begin

abbreviation A where "A ≡ TA ΔA ΔAε"
abbreviation B where "B ≡ TA ΔB ΔBε"

sublocale Δε_horn A B .

sublocale l: horn_fset "Δε_rules A B" "Δε_infer0_cont ΔA ΔB" "Δε_infer1_cont ΔA ΔAε ΔB ΔBε"
  apply (unfold_locales)
  unfolding Δε_horn.Δε_infer0 Δε_horn.Δε_infer1 Δε_infer0_cont_def Δε_infer1_cont_def set_append Un_assoc[symmetric]
  unfolding sorted_list_of_fset_simps union_fset
  subgoal
    apply (auto split!: prod.splits ta_rule.splits simp: comp_def fset_of_list_elem r_rhs_def
       map_prod_def fSigma.rep_eq image_def Bex_def simp flip: fmember.rep_eq)
    apply (metis ta_rule.exhaust_sel)
    done
  unfolding Let_def prod.case set_append Un_assoc
  apply (intro arg_cong2[of _ _ _ _ "(∪)"])
  subgoal
    apply (auto split!: prod.splits ta_rule.splits simp flip: fmember.rep_eq )
    apply (smt (verit, del_insts) Pair_inject map_prod_imageI mem_Collect_eq ta_rule.inject ta_rule.sel(3))
    done
by (force simp add: image_def fmember.rep_eq split!: prod.splits)+

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition Δε_impl where
  "Δε_impl ΔA ΔAε ΔB ΔBε = horn_fset_impl.saturate_impl (Δε_infer0_cont ΔA ΔB) (Δε_infer1_cont ΔA ΔAε ΔB ΔBε)"

lemma Δε_impl_sound:
  assumes "Δε_impl ΔA ΔAε ΔB ΔBε = Some xs"
  shows "xs = Δε (TA ΔA ΔAε) (TA ΔB ΔBε)"
  using Δε_fset.saturate_impl_sound[OF assms[unfolded Δε_impl_def]]
  unfolding Δε_horn.Δε_sound[symmetric]
  by (auto simp flip: Δε.rep_eq simp: fmember.rep_eq)

lemma Δε_impl_complete:
  fixes ΔA :: "('q :: linorder, 'f :: linorder) ta_rule fset" and ΔB :: "('q, 'f) ta_rule fset"
    and ΔεA :: "('q × 'q) fset" and ΔεB :: "('q × 'q) fset"
  shows "Δε_impl ΔA ΔεA ΔB ΔεB ≠ None" unfolding Δε_impl_def
  by (intro Δε_fset.saturate_impl_complete)
     (auto simp flip: Δε_horn.Δε_sound)

lemma Δε_impl [code]:
  "Δε (TA ΔA ΔAε) (TA ΔB ΔBε) = the (Δε_impl ΔA ΔAε ΔB ΔBε)"
  using Δε_impl_complete[of ΔA ΔAε ΔB ΔBε] Δε_impl_sound[of ΔA ΔAε ΔB ΔBε]
  by force

section ‹Computing the epsilon transitions for the transitive closure of GTT's›

definition Δ_trancl_infer0 where
  "Δ_trancl_infer0 ΔA ΔB = Δε_infer0_cont ΔA ΔB"

definition Δ_trancl_infer1 :: "('q :: linorder , 'f  :: linorder) ta_rule fset ⇒ ('q × 'q) fset ⇒  ('q, 'f) ta_rule fset ⇒ ('q × 'q) fset
  ⇒ 'q × 'q ⇒ ('q × 'q) fset ⇒ ('q × 'q) list" where
  "Δ_trancl_infer1 ΔA ΔAε ΔB ΔBε pq bs =
    Δε_infer1_cont ΔA ΔAε ΔB ΔBε pq bs @
    sorted_list_of_fset (
      (λ(r, p'). (r, snd pq)) |`| (ffilter (λ(r, p') ⇒ p' = fst pq) bs) |∪|
      (λ(q', r). (fst pq, r)) |`| (ffilter (λ(q', r) ⇒ q' = snd pq) (finsert pq bs)))"

locale Δ_trancl_list =
  fixes ΔA :: "('q :: linorder, 'f :: linorder) ta_rule fset" and ΔAε :: "('q × 'q) fset"
    and ΔB :: "('q, 'f) ta_rule fset" and ΔBε :: "('q × 'q) fset"
begin

abbreviation A where "A ≡ TA ΔA ΔAε"
abbreviation B where "B ≡ TA ΔB ΔBε"

sublocale Δ_trancl_horn A B .

sublocale l: horn_fset "Δ_trancl_rules A B"
   "Δ_trancl_infer0 ΔA ΔB" "Δ_trancl_infer1 ΔA ΔAε ΔB ΔBε"
  apply (unfold_locales)
  unfolding Δ_trancl_rules_def horn_infer0_union horn_infer1_union
    Δ_trancl_infer0_def Δ_trancl_infer1_def Δε_fset.infer set_append
  by (auto simp flip: ex_simps(1) simp: horn.infer0_def horn.infer1_def intro!: arg_cong2[of _ _ _ _ "(∪)"])

lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition "Δ_trancl_impl ΔA ΔAε ΔB ΔBε =
   horn_fset_impl.saturate_impl (Δ_trancl_infer0 ΔA ΔB) (Δ_trancl_infer1 ΔA ΔAε ΔB ΔBε)"

lemma Δ_trancl_impl_sound:
  assumes "Δ_trancl_impl ΔA ΔAε ΔB ΔBε = Some xs"
  shows "xs = Δ_trancl (TA ΔA ΔAε) (TA ΔB ΔBε)"
  using Δ_trancl_list.saturate_impl_sound[OF assms[unfolded Δ_trancl_impl_def]]
  unfolding Δ_trancl_horn.Δ_trancl_sound[symmetric] Δ_trancl.rep_eq[symmetric]
  by (auto simp: fmember.rep_eq)

lemma Δ_trancl_impl_complete:
  fixes ΔA :: "('q :: linorder, 'f :: linorder) ta_rule fset" and ΔB :: "('q, 'f) ta_rule fset"
    and ΔAε :: "('q × 'q) fset" and ΔBε :: "('q × 'q) fset"
  shows "Δ_trancl_impl ΔA ΔAε ΔB ΔBε ≠ None"
  unfolding Δ_trancl_impl_def
  by (intro Δ_trancl_list.saturate_impl_complete)
     (auto simp flip: Δ_trancl_horn.Δ_trancl_sound)

lemma Δ_trancl_impl [code]:
  "Δ_trancl (TA ΔA ΔAε) (TA ΔB ΔBε) = (the (Δ_trancl_impl ΔA ΔAε ΔB ΔBε))"
  using Δ_trancl_impl_complete[of ΔA ΔAε ΔB ΔBε]
  using Δ_trancl_impl_sound[of ΔA ΔAε ΔB ΔBε]
  by force

section ‹Computing the epsilon transitions for the transitive closure of pair automata›

definition Δ_Atr_infer1_cont :: "('q :: linorder × 'q) fset ⇒ ('q, 'f :: linorder) ta_rule fset ⇒ ('q × 'q) fset ⇒
  ('q, 'f) ta_rule fset ⇒ ('q × 'q) fset ⇒ 'q × 'q ⇒ ('q × 'q) fset ⇒ ('q × 'q) list" where
  "Δ_Atr_infer1_cont Q ΔA ΔAε ΔB ΔBε =
  (let G = sorted_list_of_fset (the (Δε_impl ΔB ΔBε ΔA ΔAε)) in
  (λ pq bs.
    (let bs_list = sorted_list_of_fset bs in
      map (λ (p, q). (fst p, snd pq))  (filter (λ (p, q). snd p = fst q ∧ snd q = fst pq) (List.product bs_list G)) @
      map (λ (p, q). (fst pq, snd q))  (filter (λ (p, q). snd p = fst q ∧ fst p = snd pq) (List.product G bs_list)) @
      map (λ (p, q). (fst pq, snd pq)) (filter (λ (p, q). snd pq = p ∧ fst pq = q) G))))"

locale Δ_Atr_fset =
  fixes Q :: "('q :: linorder × 'q) fset" and  ΔA :: "('q, 'f :: linorder) ta_rule fset" and ΔAε :: "('q × 'q) fset"
    and ΔB :: "('q, 'f) ta_rule fset" and ΔBε :: "('q × 'q) fset"
begin

abbreviation A where "A ≡ TA ΔA ΔAε"
abbreviation B where "B ≡ TA ΔB ΔBε"

sublocale Δ_Atr_horn Q A B .

lemma infer1:
  "infer1 pq (fset bs) = set (Δ_Atr_infer1_cont Q ΔA ΔAε ΔB ΔBε pq bs)"
proof -
  have "{(p, snd pq) | p q. (p, q) ∈ (fset bs) ∧ (q, fst pq) |∈| Δε B A} ∪
   {(fst pq, v) | q r v. (snd pq, r) |∈| Δε B A ∧ (r, v) ∈ (fset bs)} ∪
   {(fst pq, snd pq) | q . (snd pq, fst pq) |∈| Δε B A} = set (Δ_Atr_infer1_cont Q ΔA ΔAε ΔB ΔBε pq bs)"
    unfolding Δ_Atr_infer1_cont_def set_append Un_assoc[symmetric] Let_def
    unfolding sorted_list_of_fset_simps union_fset
    apply (intro arg_cong2[of _ _ _ _ "(∪)"])
    apply (simp_all add: fSigma_repeq fmember.rep_eq flip: Δε_impl fset_of_list_elem)
    apply force+
    done
  then show ?thesis
    using Δ_Atr_horn.Δ_Atr_infer1[of Q A B pq "fset bs"]
    by simp
qed

sublocale l: horn_fset "Δ_Atr_rules Q A B" "sorted_list_of_fset Q" "Δ_Atr_infer1_cont Q ΔA ΔAε ΔB ΔBε"
  apply (unfold_locales)
  unfolding Δ_Atr_horn.Δ_Atr_infer0 fset_of_list.rep_eq
  using infer1
  by auto

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition "Δ_Atr_impl Q ΔA ΔAε ΔB ΔBε =
   horn_fset_impl.saturate_impl (sorted_list_of_fset Q) (Δ_Atr_infer1_cont Q ΔA ΔAε ΔB ΔBε)"

lemma Δ_Atr_impl_sound:
  assumes "Δ_Atr_impl Q ΔA ΔAε ΔB ΔBε = Some xs"
  shows "xs = Δ_Atrans Q (TA ΔA ΔAε) (TA ΔB ΔBε)"
  using Δ_Atr_fset.saturate_impl_sound[OF assms[unfolded Δ_Atr_impl_def]]
  unfolding Δ_Atr_horn.Δ_Atr_sound[symmetric] Δ_Atrans.rep_eq[symmetric]
  by (simp add: fset_inject)
  
lemma Δ_Atr_impl_complete:
  shows "Δ_Atr_impl Q ΔA ΔAε ΔB ΔBε ≠ None" unfolding Δ_Atr_impl_def
  by (intro Δ_Atr_fset.saturate_impl_complete)
     (auto simp: finite_Δ_Atrans_set simp flip: Δ_Atr_horn.Δ_Atr_sound)

lemma Δ_Atr_impl [code]:
  "Δ_Atrans Q (TA ΔA ΔAε) (TA ΔB ΔBε) = (the (Δ_Atr_impl Q ΔA ΔAε ΔB ΔBε))"
  using Δ_Atr_impl_complete[of Q ΔA ΔAε ΔB ΔBε] Δ_Atr_impl_sound[of Q ΔA ΔAε ΔB ΔBε]
  by force

section ‹Computing the Q infinity set for the infinity predicate automaton›

definition Q_infer0_cont  :: "('q :: linorder, 'f :: linorder option × 'g :: linorder option) ta_rule fset ⇒ ('q × 'q) list" where
  "Q_infer0_cont Δ = concat (sorted_list_of_fset (
     (λ r. case r of TA_rule f ps p ⇒ map (λ x. Pair x p) ps) |`|
     (ffilter (λ r. case r of TA_rule f ps p ⇒ fst f = None ∧ snd f ≠ None ∧ ps ≠ []) Δ)))"

definition Q_infer1_cont :: "('q ::linorder × 'q) fset ⇒ 'q × 'q ⇒ ('q × 'q) fset ⇒ ('q × 'q) list" where
  "Q_infer1_cont Δε =
  (let eps = sorted_list_of_fset Δε in
  (λ pq bs.
    let bs_list = sorted_list_of_fset bs in
    map (λ (q, r). (fst pq, r)) (filter (λ (q, r) ⇒ q = snd pq) eps) @
    map (λ(r, p'). (r, snd pq)) (filter (λ(r, p') ⇒ p' = fst pq) bs_list) @
    map (λ(q', r). (fst pq, r)) (filter (λ(q', r) ⇒ q' = snd pq) (pq # bs_list))))"

locale Q_fset =
  fixes Δ :: "('q :: linorder, 'f :: linorder option × 'g :: linorder option) ta_rule fset" and Δε :: "('q × 'q) fset"
begin

abbreviation A where "A ≡ TA Δ Δε"
sublocale Q_horn A .

sublocale l: horn_fset "Q_inf_rules A" "Q_infer0_cont Δ" "Q_infer1_cont Δε"
  apply (unfold_locales)
  unfolding Q_horn.Q_infer0 Q_horn.Q_infer1 Q_infer0_cont_def Q_infer1_cont_def set_append Un_assoc[symmetric]
  unfolding sorted_list_of_fset_simps union_fset
  subgoal
    apply (auto simp add: Bex_def fmember.rep_eq split!: ta_rule.splits)
    apply (rule_tac x = "TA_rule (lift_None_Some f) ps p" in exI)
    apply (force dest: in_set_idx)+
    done
  unfolding Let_def set_append Un_assoc
  by (intro arg_cong2[of _ _ _ _ "(∪)"]) (auto simp add: fmember.rep_eq)

lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition Q_impl where
  "Q_impl Δ Δε = horn_fset_impl.saturate_impl (Q_infer0_cont Δ) (Q_infer1_cont Δε)"

lemma Q_impl_sound:
  "Q_impl Δ Δε = Some xs ⟹ fset xs = Q_inf (TA Δ Δε)"
  using Q_fset.saturate_impl_sound unfolding Q_impl_def Q_horn.Q_sound .

lemma Q_impl_complete:
  "Q_impl Δ Δε ≠ None"
proof -
  let ?A = "TA Δ Δε"
  have *: "Q_inf ?A ⊆ fset (𝒬 ?A |×| 𝒬 ?A)"
    by (auto simp add: Q_inf_states_ta_states(1, 2) subrelI simp flip: fmember.rep_eq)
  have "finite (Q_inf ?A)"
    by (intro finite_subset[OF *]) simp
  then show ?thesis unfolding Q_impl_def
    by (intro Q_fset.saturate_impl_complete) (auto simp: Q_horn.Q_sound)
qed


definition "Q_infinity_impl Δ Δε = (let Q = the (Q_impl Δ Δε) in
   snd |`| ((ffilter (λ (p, q). p = q) Q) |O| Q))"

lemma Q_infinity_impl_fmember:
  "q |∈| Q_infinity_impl Δ Δε ⟷ (∃ p. (p, p) |∈| the (Q_impl Δ Δε) ∧
    (p, q) |∈| the (Q_impl Δ Δε))"
  unfolding Q_infinity_impl_def
  by (auto simp: Let_def fimage_iff fBex_def) fastforce

lemma loop_sound_correct [simp]:
  "fset (Q_infinity_impl Δ Δε) = Q_inf_e (TA Δ Δε)"
proof -
  obtain Q where [simp]: "Q_impl Δ Δε = Some Q" using Q_impl_complete[of Δ Δε]
    by blast
  have "fset Q = (Q_inf (TA Δ Δε))"
    using Q_impl_sound[of Δ Δε]
    by (auto simp: fset_of_list.rep_eq)
  then show ?thesis
    by (force simp: Q_infinity_impl_fmember Let_def fset_of_list_elem
          fset_of_list.rep_eq simp flip: fmember.rep_eq)
qed

lemma fQ_inf_e_code [code]:
  "fQ_inf_e (TA Δ Δε) = Q_infinity_impl Δ Δε"
  using loop_sound_correct
  by (auto simp add: fQ_inf_e.rep_eq fmember.rep_eq)


end